texlive[62494] Build/source/utils: pmx-2.9.8a
commits+kakuto at tug.org
commits+kakuto at tug.org
Mon Mar 7 22:25:07 CET 2022
Revision: 62494
http://tug.org/svn/texlive?view=revision&revision=62494
Author: kakuto
Date: 2022-03-07 22:25:07 +0100 (Mon, 07 Mar 2022)
Log Message:
-----------
pmx-2.9.8a
Modified Paths:
--------------
trunk/Build/source/utils/README
trunk/Build/source/utils/pmx/ChangeLog
trunk/Build/source/utils/pmx/TLpatches/ChangeLog
trunk/Build/source/utils/pmx/TLpatches/TL-Changes
trunk/Build/source/utils/pmx/configure
trunk/Build/source/utils/pmx/pmx-src/ChangeLog
trunk/Build/source/utils/pmx/pmx-src/Makefile.am
trunk/Build/source/utils/pmx/pmx-src/Makefile.f2c
trunk/Build/source/utils/pmx/pmx-src/pmx.test
trunk/Build/source/utils/pmx/pmx-src/pmxab.c
trunk/Build/source/utils/pmx/pmx-src/scor2prt.c
trunk/Build/source/utils/pmx/pmx-src/scor2prt.for
trunk/Build/source/utils/pmx/pmx-src/tests/barsant.mid
trunk/Build/source/utils/pmx/pmx-src/tests/barsant.pml
trunk/Build/source/utils/pmx/pmx-src/version.ac
trunk/Build/source/utils/pmx/version.ac
Added Paths:
-----------
trunk/Build/source/utils/pmx/pmx-src/pmx298.for
Removed Paths:
-------------
trunk/Build/source/utils/pmx/pmx-src/pmx294.for
Modified: trunk/Build/source/utils/README
===================================================================
--- trunk/Build/source/utils/README 2022-03-07 20:34:21 UTC (rev 62493)
+++ trunk/Build/source/utils/README 2022-03-07 21:25:07 UTC (rev 62494)
@@ -23,7 +23,7 @@
m-tx 0.63a - checked 29apr18
https://ctan.org/pkg/m-tx/
-pmx 2.9.4a - checked 30jan21
+pmx 2.9.8a - checked 08mar22
https://ctan.org/pkg/pmx/
ps2eps 1.70 - checked 03jul21
Modified: trunk/Build/source/utils/pmx/ChangeLog
===================================================================
--- trunk/Build/source/utils/pmx/ChangeLog 2022-03-07 20:34:21 UTC (rev 62493)
+++ trunk/Build/source/utils/pmx/ChangeLog 2022-03-07 21:25:07 UTC (rev 62494)
@@ -1,3 +1,7 @@
+2022-03-08 Akira Kakuto <kakuto at jcom.zaq.ne.jp>
+
+ * Import pmx 2.9.8a.
+
2021-01-30 Akira Kakuto <kakuto at w32tex.org>
* Import pmx 2.9.4a.
Modified: trunk/Build/source/utils/pmx/TLpatches/ChangeLog
===================================================================
--- trunk/Build/source/utils/pmx/TLpatches/ChangeLog 2022-03-07 20:34:21 UTC (rev 62493)
+++ trunk/Build/source/utils/pmx/TLpatches/ChangeLog 2022-03-07 21:25:07 UTC (rev 62494)
@@ -1,3 +1,7 @@
+2022-03-08 Akira Kakuto <kakuto at jcom.zaq.ne.jp>
+
+ * import pmx-2.9.8a.
+
2021-01-30 Akira Kakuto <kakuto at w32tex.org>
* import pmx-2.9.4a.
Modified: trunk/Build/source/utils/pmx/TLpatches/TL-Changes
===================================================================
--- trunk/Build/source/utils/pmx/TLpatches/TL-Changes 2022-03-07 20:34:21 UTC (rev 62493)
+++ trunk/Build/source/utils/pmx/TLpatches/TL-Changes 2022-03-07 21:25:07 UTC (rev 62494)
@@ -1,6 +1,6 @@
-Changes applied to the pmx-2.9.4a tree as obtained from:
+Changes applied to the pmx-2.9.8a tree as obtained from:
http://www.ctan.org/tex-archive/support/pmx/
Remove:
- Makefile.in aclocal.m4 arith.h configure depcomp install-sh
- missing test-driver
+ Makefile.in aclocal.m4 arith.h compile configure depcomp
+ install-sh missing test-driver
Modified: trunk/Build/source/utils/pmx/configure
===================================================================
--- trunk/Build/source/utils/pmx/configure 2022-03-07 20:34:21 UTC (rev 62493)
+++ trunk/Build/source/utils/pmx/configure 2022-03-07 21:25:07 UTC (rev 62494)
@@ -1,6 +1,6 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.71 for pmx (TeX Live) 2.9.4a.
+# Generated by GNU Autoconf 2.71 for pmx (TeX Live) 2.9.8a.
#
# Report bugs to <tex-k at tug.org>.
#
@@ -611,8 +611,8 @@
# Identity of this package.
PACKAGE_NAME='pmx (TeX Live)'
PACKAGE_TARNAME='pmx--tex-live-'
-PACKAGE_VERSION='2.9.4a'
-PACKAGE_STRING='pmx (TeX Live) 2.9.4a'
+PACKAGE_VERSION='2.9.8a'
+PACKAGE_STRING='pmx (TeX Live) 2.9.8a'
PACKAGE_BUGREPORT='tex-k at tug.org'
PACKAGE_URL=''
@@ -1313,7 +1313,7 @@
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
-\`configure' configures pmx (TeX Live) 2.9.4a to adapt to many kinds of systems.
+\`configure' configures pmx (TeX Live) 2.9.8a to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@@ -1380,7 +1380,7 @@
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of pmx (TeX Live) 2.9.4a:";;
+ short | recursive ) echo "Configuration of pmx (TeX Live) 2.9.8a:";;
esac
cat <<\_ACEOF
@@ -1477,7 +1477,7 @@
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-pmx (TeX Live) configure 2.9.4a
+pmx (TeX Live) configure 2.9.8a
generated by GNU Autoconf 2.71
Copyright (C) 2021 Free Software Foundation, Inc.
@@ -1865,7 +1865,7 @@
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by pmx (TeX Live) $as_me 2.9.4a, which was
+It was created by pmx (TeX Live) $as_me 2.9.8a, which was
generated by GNU Autoconf 2.71. Invocation command line was
$ $0$ac_configure_args_raw
@@ -4408,7 +4408,7 @@
# Define the identity of the package.
PACKAGE='pmx--tex-live-'
- VERSION='2.9.4a'
+ VERSION='2.9.8a'
printf "%s\n" "#define PACKAGE \"$PACKAGE\"" >>confdefs.h
@@ -6464,7 +6464,7 @@
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
-This file was extended by pmx (TeX Live) $as_me 2.9.4a, which was
+This file was extended by pmx (TeX Live) $as_me 2.9.8a, which was
generated by GNU Autoconf 2.71. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
@@ -6523,7 +6523,7 @@
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config='$ac_cs_config_escaped'
ac_cs_version="\\
-pmx (TeX Live) config.status 2.9.4a
+pmx (TeX Live) config.status 2.9.8a
configured by $0, generated by GNU Autoconf 2.71,
with options \\"\$ac_cs_config\\"
Modified: trunk/Build/source/utils/pmx/pmx-src/ChangeLog
===================================================================
--- trunk/Build/source/utils/pmx/pmx-src/ChangeLog 2022-03-07 20:34:21 UTC (rev 62493)
+++ trunk/Build/source/utils/pmx/pmx-src/ChangeLog 2022-03-07 21:25:07 UTC (rev 62494)
@@ -1,3 +1,11 @@
+2.98
+ Fix beaming in 6/2 time by setting mapfb(5) and (6) = 0 in make1bar(...)
+2.97
+ Fix problem with beaming after new movement command
+2.96 and 2.95
+ replace and '\','/'. and '"' with chax();
+ eliminate do loops with shared last line
+ delete superfluous comments in source
2.94
Allow moving dots on main and chord note in 2-note termolos
Add definitions of \hbp and \hbpp to pmx.tex
Modified: trunk/Build/source/utils/pmx/pmx-src/Makefile.am
===================================================================
--- trunk/Build/source/utils/pmx/pmx-src/Makefile.am 2022-03-07 20:34:21 UTC (rev 62493)
+++ trunk/Build/source/utils/pmx/pmx-src/Makefile.am 2022-03-07 21:25:07 UTC (rev 62494)
@@ -2,8 +2,10 @@
## You may freely use, modify and/or distribute this file.
##
-INCLUDES = -I$(srcdir)/libf2c
+AUTOMAKE_OPTIONS = subdir-objects
+AM_CPPFLAGS = -I$(srcdir)/libf2c
+
bin_PROGRAMS = pmxab scor2prt
pmxab_SOURCES = pmxab.c
@@ -236,7 +238,7 @@
## pmx.test
EXTRA_DIST += tests/barsant.mid tests/barsant.pml tests/barsant.pmx \
tests/barsant.tex tests/barsant1.pmx tests/barsant2.pmx
-EXTRA_DIST += scor2prt.for pmx294.for
+EXTRA_DIST += scor2prt.for pmx298.for
EXTRA_DIST += $(PATCHES)
EXTRA_DIST += version.ac configure.ac Makefile.am Makefile.f2c
EXTRA_DIST += pmx.tex
Modified: trunk/Build/source/utils/pmx/pmx-src/Makefile.f2c
===================================================================
--- trunk/Build/source/utils/pmx/pmx-src/Makefile.f2c 2022-03-07 20:34:21 UTC (rev 62493)
+++ trunk/Build/source/utils/pmx/pmx-src/Makefile.f2c 2022-03-07 21:25:07 UTC (rev 62494)
@@ -1,7 +1,7 @@
all: pmxab.c scor2prt.c
-pmxab.c: pmx294.for
- f2c -g -\!bs < pmx294.for > pmxab.c
+pmxab.c: pmx298.for
+ f2c -g -\!bs < pmx298.for > pmxab.c
scor2prt.c: scor2prt.for
f2c -g -\!bs < scor2prt.for > scor2prt.c
Modified: trunk/Build/source/utils/pmx/pmx-src/pmx.test
===================================================================
--- trunk/Build/source/utils/pmx/pmx-src/pmx.test 2022-03-07 20:34:21 UTC (rev 62493)
+++ trunk/Build/source/utils/pmx/pmx-src/pmx.test 2022-03-07 21:25:07 UTC (rev 62494)
@@ -1,12 +1,21 @@
#! /bin/sh
-# Copyright (C) 2012 Peter Breitenlohner <tex-live at tug.org>
+# Copyright (C) 2021 Bob Tennent <rdt at cs.queensu.ca>
# You may freely use, modify and/or distribute this file.
rm -f barsant* pmxaerr.dat
+if test -r "$srcdir/tests/barsant.pmx"; then
+ : # standalone pmx
+elif test -r "$srcdir/pmx-src/tests/barsant.pmx"; then
+ srcdir=$srcdir/pmx-src # in TL
+else
+ echo "$0: cannot find tests/barsant.pmx" >&2
+ exit 1
+fi
-cp $test_src/barsant.pmx .
+cp "$test_src/barsant.pmx" . || exit 1
+
failed=
./scor2prt barsant \
Deleted: trunk/Build/source/utils/pmx/pmx-src/pmx294.for
===================================================================
--- trunk/Build/source/utils/pmx/pmx-src/pmx294.for 2022-03-07 20:34:21 UTC (rev 62493)
+++ trunk/Build/source/utils/pmx/pmx-src/pmx294.for 2022-03-07 21:25:07 UTC (rev 62494)
@@ -1,26085 +0,0 @@
- program pmxab
-c
-c This program, PMX, developed by Don Simons
-c (dsimons at roadrunner.com), is a preprocessor for MusiXTeX. In concert with
-c MusiXTeX and TeX, its purpose is to allow the user to create high-quality
-c typeset musical scores by including a sequence of PMX commands in an ASCII
-c input file.
-c
-c This program is free software: you can redistribute it and/or modify
-c it under the terms of the GNU General Public License as published by
-c the Free Software Foundation, either version 3 of the License, or
-c (at your option) any later version.
-c
-c This program is distributed in the hope that it will be useful,
-c but WITHOUT ANY WARRANTY; without even the implied warranty of
-c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-c GNU General Public License for more details.
-c
-c You should have received a copy of the GNU General Public License
-c along with this program. If not, see <http://www.gnu.org/licenses/>.
-c
-c
- character*9 date
- character*5 version,versionc
- common /comver/ versionc
-c
-c To compile with gfortran:
-c 1. Merge all files using copy *.for epmx[nnnn].for
-c 2. Search and replace all character*65536 with character*131072
-c 3. Comment/uncomment getarg lines
-c 4. gfortran -O pmx[nnnn].for -o pmxab.exe
-c
-c To do
-c Correct Rainer's email address in manual
-c Linesplit (\\) in h
-c Tt at start of a movement.
-c Toggle midi on or off; allow midi only.
-c Page number printed on 1st page even if 1 system.
-c Still need inserted space for chordal accidentals
-c Voicewise transposition.
-c better segno
-c coda
-c duevolte
-c Fix xtup bracket direction in 2-line staves?? (maybe leave as is)
-c Sticky ornaments with shifts.
-c Deal with Werner's vertical spacing thing associated with title.
-c Multiple ties in midi
-c Werner's missing c in MIDI due to start/stop ties on same note.
-c Beams with single 64ths
-c 128ths and/or dotted 64ths
-c Close out MIDI with integral # of beats?
-c Increase ast dimensions or redo logic.
-c Does slur direction get set for user-defined single-note stem dir'ns?
-c Transpose by sections.
-c Optimization loop over sections only
-c Command-line option to read nbarss in. Write out nbarss when optimizing.
-c (or just read from .plg?)
-c Beams over bar lines.
-c 2-digit figures
-c A real coule (slanted line between notes in a chord)
-c Dotted slurs for grace notes.
-c Undotted chord notes with dotted main note.
-c Forced line break without line number
-c Fix dot moving when 2nds in chord get flipped
-c To do: increase length on notexq in dodyn
-c 2.94
-c Allow moving dots on main and chord note in 2-note termolos
-c Add definitions of \hbp and \hbpp to pmx.tex
-c 2.91
-c Tweak: insert \stdstemfalse before every user-shortened or lengthened stem.
-c This cancels defaul extensions to middle line and also (with 'L') allows
-c stems that are longer than 4.66 but still don't reach middle line.
-c Allow alteration of number height in multibar rest, option n.
-c Fix bug introduced in 2.89 so that the "o" in "mo800" is now OK.
-c 2.90
-c Many tweaks to allow gaps at end or middle of a system using
-c L[n]S[x] and LC[y]. New pmx.tex.
-c 2.88
-c Comment out print*,"Changed pathname to..." since it was going
-c iteration when optimizing linebreaks with the undocumented option Ao.
-c Add nv back in as argument for getmidi, so loop transferring data
-c from midivel to midvelc can be executed. This corrects bug and
-c allows per-instrument change in midi velocities at the start
-c of any block
-c Add subroutine inst2chan to transfer midi data as noted above. Works with
-c Iv but buggy when used with IT and Ib
-c 2.87
-c Allow changes to and from octave treble clef. Instrument with it
-c must only have one staff.
-c Some fixes for beam multiplicity changes at staff jumps. Must still
-c use inline for mult. increase at downward staff jump. See sjb.pmx.
-c 2.84
-c Bug fix: dots in chordal seconds
-c Bug fix: Initialize ihornb for non-beamed, down xtup
-c Bug fix: When using "AT" with 2-note x3c rD.
-c 2.83
-c Fix problems when changing to or from octave treble clef.
-c Fix beaming (or not) and number location for xtups with
-c multiple rests. Still some problems with number height but
-c can be band-aided with number height tweak option.
-c Tweak error messages for options on "R" command.
-c Allow forced beam height and slope tweaks with 2-note tremolos
-c Allow chordal note with 2-note tremolos, adding dots as needed.
-c Fix call to ncmid in beamstrt when setting start height for beam of
-c 2-note trem, by changing arg from ivx to iv
-c 2.82
-c bugfix: beams with rests, not confused with xtups.
-c x option after slur index to allow slurs to go from one voice to another.
-c x option also for ties
-c 2.81
-c Allow string of rests to end xtup
-c in chordal half-note 2-note tremolo, make chord notes open.
-c 2.80
-c Add 2-note tremolos
-c 2.78
-c Expand bufq to 131072 bytes
-c Expand maxblks tp 9600
-c Allow up to 75 pages
-c Index postscript hairpins from 1 up instead of by voice #.
-c Add option 'o' to forced beam for open notehead (\hb); set ipl(3)
-c Add option T[n], n=1,2,3 for single stem tremolo
-c 2.77
-c Enable AV+/-x+/-y to add vskip bigh before or after \eject
-c 2.76
-c 2.75
-c Bugfix: unbeamed xtups with dots: in beamn1 and beamid allow dotted 16th, and
-c 2 or 3 flags on shortened note.
-c 2.74
-c Bugfix: allow "0" as argument of @ command on lyrics string.
-c Check for and allow "\ in centered page headings with P command.
-c Check for and allow "\ in text dynamics with D command.
-c For lyrics string starting in xtuplet, insert check for inputting musixlyr.
-c For staff-crossing beamed xtuplet chords, if 2nd segment of a joined beam
-c starts with a blank rest, put '\sk' into the TeX.
-c To enable high-to-both beamed etup staff-crossing chord, for blank
-c rest at start of forced beam, shift \sk's from before to after \ib..;
-c so \ib is at start and note in upper voice has a beam to connect to.
-c Expand range of vertical xtup number shift, now stored in mult(16-22)
-c Check for and allow \" within lyrics strings, for umlauts.
-c 2.73 (160121)
-c Dirk's "..." command, to convert "text" into \pmxlyr{text}\ and insert as
-c inline TeX. Replace all '~' inside "..." and not preceded with '\', by
-c '\lk '. Right after 2nd ", replace @[a,b][+,-]n with \at{[a,b][+,-]n}\
-c Include definitions of \ly and \at in pmx.tex (2 Feb 16). After first ",
-c add (as type 2 string) '\\input musixlyr \'
-c After inputting pathname, change any '\' to '/', for Linux compatibility.
-c 2.72 (160110)
-c Really finalize \mbrest...go back to 3 args to deal with clef changes.
-c Fine tune centered whole bar rests to deal with clef changes
-c Fix bug in wsclef when >1 staff per instrument, since \setclef
-c needs to know instrument and specify clefs on all staves for that
-c instrument. Ones that were not changed by user will not be printed,
-c and will be kept the same as before.
-c Fix bug with arpegii from one voice to another in same staff.
-c 2.71 (151226)
-c Finalize mbrest mods
-c 2.705
-c Fix error message
-c 2.704 (140614)
-c Octave treble clef
-c Make horizontal ornament shift (ornhshft) floating
-c 2.703 (140323)
-c Option v[-]n at end of any figure will alter figdrop for rest of system
-c 2.702
-c Stem slurs. Only for ps, assume no other pos'n adjustments. Option "v"
-c 2.701
-c oC = coda (\code{10})
-c Move iornq(29) (blank barline) to ipl(0) (changes in pmxb, getnote)
-c oG = new seqno
-c To do: fix grace note spacing problem (partially done)
-c 2.622
-c Redefine midtc(..) and miditran(..); clean up all transpositions/key changes
-c Kn[+/-...] \ignorenats at signature changes
-c Fix tie checks in doslur() and dopsslur() to subtract iTransAmt from nolevs
-c before checking and setting pitch levels levson() and levsoff()
-c Define midisig separately from isig. Put in common commidisig.
-c Use for explicit midi signature and for accid corrections to midi piches
-c in addmidi.
-c 2.621
-c Make keyboard rest option work in xtuplets. Created subroutine
-c chkkbdrests, modified make2bar to include calls to chkkbdrests as rqd.
-c 2.620
-c Allow user-defined rest height tweaks at start of beam.
-c 2.619
-c At movement break, change \nbinstruments in \newmovement macro; add
-c 3rd arg to \newmovement in pmx.tex; modify pmxb.for and getnote.for
-c to remove call to newnoi and change call to \newmovement
-c 2.618
-c Add option Ac[l,4] to set vert and horiz size and offsets to properly
-c center page for letter or a4 paper.
-c 2.617
-c In g1etnote, change if-check for note to use index(...) instead
-c of ichar(charq) since it was messing up gfortran optimizer
-c After pmxa, search for and remove penultimate line <blank><blank>/
-c because it was screwing up linux-compiled versions
-c Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...)
-c 2.616 (111110)
-c Allow hairpins to span multiple notes groups (gulps).
-c 2.615+ (110810)
-c Fix midi when some instruments are transposed, by subtracting
-c iTransAmt(instno(iv)) from pitch values sent to via addmidi in
-c make2bar.for (for main notes) and docrd (for chord notes)
-c 2.615 (110725)
-c Fig bug with size-setting (in topfile) when instrument has >1 staves
-c 2.615 (110724)
-c Make AS[0|-|s|t]... really set sizes
-c 2.614
-c Mod notex.for to fix Terry's bug with raised dotted rests (caused
-c by double-hboxing).
-c 2.613
-c Bugfix: In pmxa, change "do while" limit to keep from overwriting instno.
-c 2.612
-c Enhance AS to allow s or t for smallsize or tinysize
-c 2.611
-c Error trap for "D" before any notes in a block.
-c 2.610
-c Instrument-wise key changes and transposition (incomplete)
-c 2.603
-c 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors
-c following reading in an include file.
-c 101121 Added some error messages in g1etset.for setup data
-c 2.602
-c Correct slur indexing in linebreakslurs.
-c Account for comment lines in line count for error messages
-c 2.601
-c Bug fix: allow 24 slurs with graces
-c 2.60 Changes made make it really big
-c increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o
-c major reprogramming, and 16 may also be a problem (icmm)
-c nm=24 (voices) done
-c 24 slurs done
-c 24 simultaneous beams (Replace index 24 by 0, so get 0-23)
-c bufq*131072 (gfortran only)
-c getarg syntax (gfortran only)
-c 2.523+
-c Fix voice numbering for normal dynamics and text dynamics
-c 2.523
-c Version of bigpmx first posted to Hiroaki's web site.
-c 2.522
-c 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it.
-c With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices.
-c 5/13/10 Fix log2 function
-c 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length.
-c 2.521+
-c 091025 Enable dotting 2nd part of linebreak slur or tie.
-c To adjust barno height due to linebreak slur, use \bnrs instead of
-c explicitly redefining \raisebarno (pmxb)
-c 2.521
-c Bugfix
-c 2.520
-c 090519 Enable ligfonts (special figured bass characters)
-c 2.519
-c Fix another bug which kept \sk from being output so misaligned some notes.
-c 2.518
-c Fix bugs: referencing fig data, char declaration for member of
-c common/comfig/
-c 2.517
-c Allow figures in voice 1 + any one other.
-c 2.516
-c Allow figures in voice #2
-c 2.515+ to do: Change manual and activate rule against clef change in voice #2.
-c 2.515
-c 071222 Changes in getnote to allow auto forced beams to start anywhere.
-c 071206 In make2bar, shift fermataup7 to left over centered pause.
-c 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line
-c staff (it was screwing up vertical justification).
-c n34 for tweaks to midi durations of quarter note septuplets.
-c To do: In ref250.tex, the tables where 's,t,)' is explained, the line
-c [+,- i] ... Vertical adjustment of the start of second segment
-c should it be replaced by
-c [s +,- i] ... Vertical adjustment of the start of second segment
-c 2.514
-c Changes in make2bar to get horizontal spacing right when normal grace
-c follows after grace
-c Changes in dograce to get octaves right for any material entered inside
-c \gaft, which shields transpose register changes from the outside world.
-c 2.513
-c In make1bar, near end, for forced beams starting with a rest, copy hgt and
-c slope tweaks to ALL notes after first, not just the second one, so if
-c there's more than one rest at start the tweaks are still observed.
-c In beamid and beamend, add stand-alone triply-flagged notes for xtups.
-c 2.512
-c Near end of pmxb, fix error trap to allow redundant 'RD'
-c Enable multiplicity down-up '][' within xtup.
-c 2.511
-c Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by
-c adjusteskz as in bar 7 of barsant.
-c 2.510a
-c Test: remove restriction on tempo changes in MIDI macros
-c Send to CM for beta testing.
-c 2.509+
-c To do: Correct manual on AS. "-" is for smaller staves.
-c 2.510
-c Forgot to declare litq, voltxtq as character in subroutine getgrace
-c 2.509
-c Corrected small bug in arpeggio shifting (ivx <= iv in call putarp)
-c 2.508
-c Allow graces in xtups. New subroutine getgrace.
-c 2.507
-c To do: Raise/lower figures.
-c To do: Add 24, 29 to list of musicsizes in manual
-c New sub adjusteskz to account for ask's when computing lengths of
-c brackets for unbeamed xtups, slopes and horizontal posn's of number
-c Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags
-c Add look-left option for keyboard rests, "L" in rest command, set iornq(30)
-c 2.506
-c Fix bug with AK, when simultaneous rests have same duration, use defaults.
-c 2.505
-c Keyboard rests AK
-c 2.504
-c Space after normal grace: option X[n]
-c Fixed og when nv .ne. noinst, by using sepsymq instead of '&'
-c (To do) length of xtup bracket when there is added non-collision space.
-c Trap musicsize if .ne. 16,20,24,29.
-c 2.503
-c Enable arpeggio left shift with ?-x
-c To do: In manual, arpeggio over 2 staves.
-c Allow musicsize of 24 and 29. Had to define meter font size explicitly,
-c also change font size for text dynamics, but not much else so far.
-c Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn
-c was called, causing error in printing replacement number.
-c 2.502
-c Incorporate Dirk Laurie's patch to use { , } , for ties.
-c Figure height adjustment: append +[n]
-c Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?)
-c 2.501
-c Readjust horizontal offset back to .8 in LineBreakTies
-c Fix zero-subscript (iudorn) in putorn
-c 2.50
-c Increase number of text-dynamics (dimension of txtdynq) per block
-c from 12 to 41.
-c Slur option n to override altered default curvature.
-c Allow default ps slur curvature tweaks with Ap+/-c
-c 2.416
-c Increase length of textdynq from 24 to 128
-c (Todo) Add comment in manual about blank lines at end.
-c Configuration file: Define subroutine getpmxmod, check path in environment
-c variable pmxmoddir, check existence, read lines into bufq after setup.
-c Increase dimension on idynn in dodyn from 4 to 10 for max number
-c of marks in a bar
-c Increase allowable # of lines from 2000 to 4000.
-c (To do) Replace definition of \liftpausc per Olivier.
-c (To do) Fix extraneous error message if RD is placed at very end.
-c 2.415
-c Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt
-c instead of redefining \xnum. Change font used to \smallfont (as for
-c normal xtups,
-c Allow slur to start on rest.
-c 2.414
-c Correct bug in crdacc when adding accidental to boundary causes number of
-c segments to decrease
-c Special rule for 3-accidental chords: If no 2nds, place them in order
-c top, bottom, middle.
-c 2.413
-c Correct bugs in chordal accidentals, related to left-shifted noteheads
-c (a) Special problems with downstem when main note needs shifting
-c (b) Assign 0 rank to boundary segs due to left-shifted noteheads
-c 2.412
-c Change default horiz shift of start of seg 2 of linebreak slurs:
-c -.7 for slurs, -1.2 for ties,
-c Use height of start of seg 1 slur itself for end of 1 and start of 2.
-c 2.411
-c "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2.
-c "s" option in start of slur/tie as precursor to vert/horiz tweaks for end
-c of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2.
-c With "Apl", curvature adjustments on starting slur command apply to seg 1,
-c those on ending command to seg 2.
-c 2.410
-c "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine
-c \xnum, \unbkt, \ovbkt.
-c "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is
-c flag, mult(5-9) is tweak value+16
-c 2.409
-c Bugfix in docrd for MIDI: Use original pitch in case main/chord were
-c switched due to 2nds.
-c Remove "o" from error message for "A" command.
-c New syntax: optional instrument number separator ":" in movement
-c break command to precede a 2-digit instrument.
-c Conditional output formats for \setname at movement break to allow
-c instrument numbers >9.
-c Bugfix in coding to raise barno due to slur over line break (pmxb)
-c Move date/version data statement in pmxab to a better place.
-c 2.408
-c Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar).
-c Bug fix in \liftPAusep in notex.for and in pmx.tex
-c Character variables for version and date
-c For up-stem single graces slurred to down-stem, shift slur start left by
-c 0.8 so slur doesn't get too short.
-c Initialize and slide mult, same as other full-program variables in /all/.
-c 2.407
-c Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n,
-c 2.406
-c Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing
-c equalization).
-c Put dimensions of double sharps and flats in crdacc (for chords).
-c Bugfix: Use sepsymq in LineBreakTies(..) instead of '&'
-c Use only first 4 bits of mult for multiplicity+8, so rest can be used
-c for other stuff.
-c Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict.
-c 2.405: Not published but saved for safety.
-c Option Aph to write \special{header=psslurs.pro} top of each page, so
-c dviselec will work OK.
-c 2.404
-c Allow slur to end on rest, but not start on a rest. Efaults height
-c of ending is default height of start (before any automatic or user-
-c defined djustments). User may adjust height as normal from default.
-c 2.403
-c Bugfix: turn off repeated beaming patterns.at end of non-last voice.
-c 2.402
-c Automatic repeated forced beams. Start with "[:" End with next explicit
-c forced beam or end of input block.
-c Increase # of forced beams per line of music per input block from 20 to 40
-c 2.401
-c Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies.
-c Makes 1st part normal shape, and starts 2nd part a little further left.
-c Enable arpeggios in xtuplets. Had to make time itar(narp) a real.
-c 2.40
-c Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap.
-c Fix non-ps-slur input to \midslur (third signed integer). Do not reverse
-c sign for down-slurs.
-c 2.359
-c Add error exit subroutine stop1 to make exit status g77-compatible..
-c Absolute octave on xtup chord note was 2 octave too high, fixed in getnote
-c Fermata on vertically shifted rest: special trap in putorn() to set height.
-c Correct multiple grace note spacing for small staves (in dograce,
-c define wheadpt1 depending on staff size)
-c 2.358
-c Allow curvature corrections at start of postscript slur, in dopsslur()
-c Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust
-c Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h]
-c Make t[ID] act like s[ID]t, most mods in spsslur().
-c Add spsslur() to read in data for ps slurs, call from getnote.
-c In beamstrt, save args for SetupB in common comipb to save them for
-c 2nd call when xtup starts with rest
-c Add spacing for ornament ")" as if it were accidental, in make2bar().
-c Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur()
-c Horiz. shift start of ps grace slur, 2 places in dograce().
-c Horiz shift end of grace slur in endslur()
-c Make st slurs into postscript ties. Separate subroutine dopsslur(),
-c Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.)
-c Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn.
-c 2.357a
-c Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote
-c 2.357
-c Increase dimension for # of lit TeX strings from 52 to 83.
-c Allow blank rest in middle of xtuplet. Only mods in g*etnote().
-c 2.356
-c Increased some dimensions from 30 to 40 to allow up to 40 pages.
-c In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt().
-c Fix parsing of "f,h,H,HH" in sslur.
-c Fix bug with cdot, note-level for slur termination (in getnote)
-c 2.355
-c Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)],
-c n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues
-c Make midi recognize ps ties in doslur.
-c Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote
-c to get octave right.
-c 2.354
-c With postscript slurs, make t-slurs real ties by inserting replacement
-c macros \tieforisu, etc, defined in pmx.tex
-c Check for open cresc or decresc at end of input block, using list[de]cresc
-c Hairpin syntax conditional on postscript slurs. Backup to fill in start
-c level, using new backfill(...). Separate height tweaks for
-c start and finish.
-c 2.353
-c K-0+n to transpose by half step (rather than just change key)
-c Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of
-c \mbrest's
-c Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end
-c of input block before movement break, and at start of block after
-c movement break, using \newmovement rather than \setzalaligne, since
-c former already redefines \stoppiece. In second case, set rptfg2='z'.
-c Make clefq(nm) common between pmxb and getnote; change references in
-c getnote at 'M' to array elements, setting all new clefs as you go.
-c 2.352
-c Remove \parskip redefinition from pmx.tex; write it into TeX file when
-c "Ae" is invoked.
-c Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine
-c \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH',
-c translate them thru mapping to (1,4,5,6) as \midslur params, then let
-c \psforts translate them back to ps slur macors.
-c 2.351
-c Number slurs from 0 up instead of 11 down, anticipating postscript slurs.
-c Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size.
-c Increase length of basenameq to 44 characters everywhere.
-c Increase dimension of mcpitch (midi-chord-pitch) to 20.
-c Set default systems per page to 1 if nv>7
-c In pmxb, move place where isystpg is reset to 0, so that \eject gets
-c written when there is just one system per page.
-c 2.35
-c Cautionary accidentals with 'c' anywhere in note symbol.
-c NEW pmx.tex with \resetsize to set size to normal or small depending on
-c current \internote. Used with new coding in dograce() to get right
-c new size in case user has \setsize'ed some lines to \smallvalue. For
-c \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font.
-c Affects pmx.tex.
-c Continuation figure with fractional length. May now mix with other figures.
-c If another figure follow Cont-fig, separate with colon.
-c 2.342
-c Bugfix in getnote to recognize relative octave shift in grace at start of
-c input block.
-c In make2bar, initialize islhgt=0 earlier than before (possible solution
-c to Suse g77 compile problem that I could not reproduce)..
-c Bugfix in beamstrt & beamn1 for r2x6 c4D d d d
-c 2.341
-c Syntax check: Forced page break page number must be > than previous.
-c Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb.
-c 2.34
-c New pmx.tex with redefined liftpausc
-c Bug fix with dotted, non-beamed xtups.
-c 2.332
-c Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads.
-c Allow arbitrary pos. input to W in g1etnote and getnote.
-c 2.331
-c Bug-fix in dodyn(..): typo on length of arg of txtdyn
-c 2.33
-c Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata()
-c 2.321
-c Rescale accidental shifts. Still use 7 bits but now map (0,127)
-c onto (-1.,5.35)
-c Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups
-c 2.32 (Noticed after posting)
-c Prohibit "/" as figure.
-c 2.32 (Posted)
-c Tidied up accidentals in chords, do spacing.
-c Still to do:
-c check for "(" on chord notes in spacing algo
-c small accids
-c double accids
-c autoshift slurs
-c 2.310
-c Extra call to precrd ahead of spacing chk, and single-note crd/acc
-c shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time.
-c 2.309
-c Alternate algo for accid shifts in chords.
-c 2.308
-c Auto horiz. notehead shifting added to precrd.
-c 2.307
-c Auto shifting of multiple accidentals in chords.
-c "Ao" in main chord note to keep accidentals in order. Set nacc(28).
-c If there are any manual main or chord note shifts, then
-c If any manual shift is preceded by "A" then
-c 1. Auto-shifting proceeds
-c 2. "A"-shifts add to autoshifts
-c 3. non-"A" shifts are ignored!
-c Else (>0 man shifts, none has "A")
-c No auto-ordering, No autoshifts,
-c End if
-c End if
-c 2.306
-c Initialize legacy note level to middle C in case user forgets to set
-c octave.
-c Shift xtup note?
-c Shift in elemskips rather than noteheads?
-c 2.305
-c Stop pmxb from multiple endvolta's at start of new page.
-c 2.304
-c "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on
-c for multiple notes in the voice, "S:" last shortened note.
-c 2.303
-c vshrink stuff all OK? Description is in pmxb.
-c 2.302
-c Toggle vshrink with "Av". vshrink normally kicks in when \interstaff
-c hits 20. This still needs work.
-c Add " /" to last line if last char is not % or /.
-c 2.301
-c Check in beamn1 for single note before multiplicity down-up.
-c allow '.PMX' as well as '.pmx'
-c 2.299
-c Correct typo in pmxb involving PMXbarnotrue.
-c Replacement printed number for xtup: Unsigned integer after 'n' after 'x'
-c Minor upgrade parsing xtuplet options 'x...'
-c Correct dimension of nxtinbm in make2bar.
-c 2.298
-c Account for doubled xtup notes in subroutine getx (user-defined spaces),
-c by adding ndoub as an argument..
-c 2.297
-c Created and solved compiler problem. Put drawbm(NM) in its own common.
-c Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar
-c when \centerbar is used.
-c Modify \mbrest & \CenterBar in pmx.tex to use \volta at endcor etc. Have PMX
-c use right 2nd and 3rd args for \mbrest when key, meter, or clef changes.
-c 2.296
-c Correct printed numbers for forced beams with multiple xtups. For each beam
-c make list in setupb by voice of eloff (h-offset) and mtupv (printed #)
-c Increase lengths of jobname and infileq by 20 characters
-c Enable whole notes and breves as 1st or last note of xtup in beamn1 and
-c beamend, and wholes in beamid.
-c 2.295
-c Midi balance Ib[n1]:[n2]:...[nn]
-c Single-slope beam groups [...]-[...]
-c Trap "i" unless after accidental (main notes, xtups, chord notes)
-c 2.294
-c Unequal xtups with "D" to double a note in an xtup.
-c As above, "F" will (a) increase multiplicity by 1 for marked note and next
-c one and (b) add a dot to the first one.
-c Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on
-c when "." is encountered, then correcting beam start time.(end of getnote)
-c MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]...
-c 2.293
-c Check for single notes spanning bar lines.
-c Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup
-c must be set in make2bar since beamstrt is not called, fixing problem with
-c dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix
-c problem when >2 staves.
-c Add nodur to args of dodyn, so can check if stemless and avoid height tweak
-c Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak
-c 2.292a
-c Undo syntax check for Type 2 or 3 TeX string starting in column 1.
-c Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?!
-c 2.292
-c Allow comments in xtuplets
-c Enable multiple octave jumps in grace notes.
-c Allow dynamics in xtuplets.
-c Fix bug in getdyn searching for end of text string (correct length of lineq
-c to 128)
-c Fix bug in dodyn, must ignore horiz. interaction tweak for
-c user-text (idno = 0)
-c Syntax check for Type 2 or 3 TeX string starting in column 1
-c (NOTE: later undone!)
-c Syntax check for page number > npages at forced line break.
-c 2.291
-c Fix error in AS command (accid spacing for small systems), making only
-c one spec per staff, nv total.
-c Stop using MIDI channel 10
-c 2.29
-c Fix error in console output format for # of bytes used in MIDI file.
-c Fix bug in dograce so no space is added between grace and main note when
-c there is a MIDI-only accidental.
-c Fix bug so oes?+4 works. It was too ugly to explain.
-c ...Different ways of storing accidental specs on input and output.
-c No longer zap \writezbarno in special situations.
-c Fix bug in dyntxt level on rest
-c Line spacing equalization. Add macros \starteq, \endeq, \spread, etc.
-c Activate with Ae. (Maybe later could input alternate values for
-c \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1
-c in the page, and \endeq on 1st note of next-to-last line in page.
-c 2.28
-c Flip direction of forced beam "[f..."
-c Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30)
-c Fix bug in sliding ip's for txtdyn's
-c In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99)
-c 2.27
-c Comment out lines in dodyn checking number of dynamic marks found. Voice
-c order may not be monotonic if two lines on a staff.
-c Literal dynamic: D"[text]"
-c 2.26
-c Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn,
-c increasing dimension of idynn to 4 to allow 4 symbols on same note.
-c Increase voltxtq length from 10 to 20.
-c AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough
-c accounting for ast's is done by defining effective headwidth
-c whead1 in makebar2 to be 0.8*whead.
-c 2.25
-c Fix logic bug with sepsym's when # of instruments changes.
-c Slight increases in default offsets for hairpin starts after "p"
-c 2.24
-c Hairpins D< or D> as toggle.
-c Many automatic position tweaks for letter-group dynamics and hairpins.
-c 2.23
-c Continued rhythmic shortcuts: space followed by "." or ","
-c 2.22
-c In call to doslur, change tno(...) to tnote(...). This was only
-c used when checking to slurs per stem directions, and should have been
-c the note duration all along.
-c MIDI-only accidental, bit 17 in nacc, or 27 in icrdat.
-c Use "i" anywhere in note symbol.
-c 2.21
-c Increase from 20 to 30 dimensions for movement breaks and midi sections.
-c Fix out-of-order declarations per mutex comments
-c Add "Bad error" and "Kluging" messages to log file.
-c 2.197
-c add /comips/ to save tie-check midi variables
-c For spacing of clef changes at start of input block, changed integer time
-c lastnodur to prevtn, so it works with xtups. Possible incompatibility!
-c 2.196
-c Fix Ickbug with time check in ncmid()
-c Interchange \fermataup7 and \pausec to get proper alignment
-c Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX.
-c Add defn's of \hsp, \hspp to pmx.tex
-c Fix pre-slurs on xtup chord notes.
-c Fixed raised PAuse, define \liftPAuse
-c Replace \zbreve\sk with \breve.
-c Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what
-c about "o" and 1 as shorthand for 16???? Search for "Kluge"
-c Added "vo" (voice) as MIDI instrument 55
-c Allow 3-digit page numbers (search for "toppageno")
-c Fix bug caused by prior fix (cancelling accid after bar line was ignored).
-c Fix double accids in chords
-c 2.194
-c Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if
-c block.
-c Add meter to MIDI file with every pause
-c Purify FORTRAN?
-c 2.193
-c Increased # of in-line TeX strings from 36 to 52.
-c Fix entry of # of bytes in header of tempo/meter/key track to allow >255.
-c 2.191
-c Event track: Tempos, meters, keys all together. Data in comevent
-c 2.15
-c Pretty good midi capability. Still no attention to slurs on chord notes.
-c 2.11
-c 11 Dec 99 c rm1
-c 11 Dec 99 "oes?", "oe?"
-c 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes
-c 11 Dec 99 Error message for shifted, repeated ornaments.
-c 2.10 (Version 2.1)
-c Fix bug with lowdot and xtuplets
-c 2.09
-c Fix bug with multiple ornament heights over beams, when one is . or _
-c Error message from pmxa if rest on last note of xtup.
-c Enable 12 slurs.
-c Reinstate multiple rests at start of xtup.
-c 2.07
-c Combine consecutive type-1 TeX strings.
-c \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's.
-c Fixed breve chord notes in docrd
-c Check irest(28) as well as vxtup when setting nodur for chord notes, since
-c vxtup isn't set until 1st *main* note in xtup
-c Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing.
-c 2.06+
-c Make deterministic the beam slope calculation when there are an even # of
-c slopes in list and middle two are equal magnitude but opposite sign.
-c pmxa Trap for "o:" before 1st note in block
-c Partial bug fix for 64th notes in xtuplets.
-c Make ixrest a vector, since with new time scheme may not finish xtup in
-c same notes block.
-c Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb)
-c 2.06
-c Account for changes in nv when computing \interstaff. Add a counter
-c nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever
-c setting isysflb(iflb). Note nv can only change at a forced line break.
-c Note also, iflb starts at 0!
-c 2.05
-c Automatic start of new notes group with part 2 of staff-jump beam
-c In make1bar, set irest bit 29 of lowest-voice note at same time,
-c use as flag when making notes groups.
-c For now, remove dummy blank line at end...it zaps terminal repeats.
-c 2.02
-c Fixed slur-counting bug for multiple, slurred, aftergraces.
-c 2.01
-c Increase to ask(1400)
-c Increase max forced page breaks to 18
-c Define pausc for centered pause
-c 2.0a
-c Insert dummy blank line at very end to handle input files w/o terminal CR-LF
-c pmx03r
-c Option m[n] in S symbol to change musicsize (for parts)
-c Double dotted rests now work.
-c Write file name to log file
-c Check existence of input file
-c Allow 24-char jobname, may end with ".pmx"
-c Comment out time stuff
-c Replace 3-argument getarg with 2-argument + iargc
-c Fix bug with negative noinst due to nint<=int replacement
-c move lovation of iv in isdat1 to allow iv>7.
-c Set nm=12
-c pmx03q
-c replace int(x+.001) with nint(x)
-c Write TeX file name to screen and to pml.
-c Replace char(...) with chax(...) to sovle msdev bug.
-c Bug fix: macro terminations when M is on a line by itself.
-c Bug fix: don't accumulate space for XS in pmxa.
-c Streamline Macros: use pointers to bufq instead of scratch files
-c pmx03p
-c Store input file in single character array bufq.
-c lbuf(i)*2 is length of line i
-c ipbuf is position just before next line to be read.
-c pmx03
-c Optimize read/writes
-c pmx02
-c Fix line count (for errors) when there are saved macros
-c pmx01
-c In optimize mode, open/close macros (Watch out for residual zz files!)
-c Command line input
-c Option Ao to optimize, otherwise normal processing
-c
-ccccccc
- parameter (nks=125,nm=24,mv=24576,maxblks=9600)
- character*128 lnholdq
- character*131072 bufq
- integer*2 lbuf(maxblks)
- common /comevent/ miditime,lasttime
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
- integer*2 iinsiv
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- common /commus/ musize,whead20
- integer*4 nbars0(nks),nbars(nks),ipoe(nks),nbari(nks)
- real*4 poe0(nks),poe(nks)
- logical isfirst,optimize
- logical*4 fexist
- character*44 jobname
- character*47 infileq
- common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm),
- * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
- * idum,itsofar(nm),nib(nm,15),nn(nm),
- * rest(nm,200),lenbr0,lenbr1,firstline,newmeter
- logical rest,firstline,newmeter
- common /comdiag/ n69(0:nm),n34(0:nm)
- logical mmacrec,gottempo
- common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
- * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60),
- * mmacrec,gottempo
- common /truelinecount/ linewcom(20000)
-c
-c Added 130302 only to get nsperi from g1etnote, for use in midi setup
-c
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,fbon,issegno,isheadr,isvolt
-c
-c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing
-c nmidsec section starts and stops based on PLAYING macros (not recording).
-c
-ccccccccccccccccccccccccc
-c
- data date /'17 Mar 20'/
- data version /'2.94'/
-c
-ccccccccccccccccccccccccc
- data maxit,ncalls /200,0/
- data isfirst /.true./
-c itstart = mytime()
- versionc = version
-c
-c Initialize midi parameters
-c
- gottempo = .false.
- ismidi = .false.
- debugmidi = .false.
- relacc = .false.
- mmacrec = .false.
- nmidsec = 1
- mgap = 10
- miditime = 0
- lasttime = 0
- nmidcrd = 0
- nusebl = 0
- notmain = .false.
- do 3 ivx = 1 , nm
- twoline(ivx) = .false.
- midinst(ivx) = 6
- midivel(ivx) = 127
- midibal(ivx) = 64
- miditran(ivx) = 0
-3 continue
- do 12 icm = 0 , nm
- imidi(icm) = 0
- restpend(icm) = .false.
- trest(icm) = 0.
- levson(icm) = 0
- levsoff(icm) = 0
- slmon(icm) = .false.
- naccbl(icm) = 0
- n69(icm) = 0
- n34(icm) = 0
- msecstrt(icm,1) = 1
-12 continue
-c
-c End of midi parameter initialization
-c
- musize = 0
- optimize = .false.
- numargs = iargc()
- if (numargs .eq. 0) then
- print*,'You could have entered a jobname on the command line,'
- print*,' but you may enter one now:'
- read(*,'(a)')jobname
- numargs = 1
- else
-c call getarg(1,jobname,idum) ! May need to replace this w/ next line
- call getarg(1,jobname)
- end if
-10 ljob = lenstr(jobname,44)
- if (ljob .gt. 44) then
- print*,'Jobname is too long. Try again.'
- call stop1()
- else if (ljob .eq. 0) then
- print*,'No was jobname entered. Try again.'
- call stop1()
- else if (numargs .eq. 2) then
- if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then
- optimize = .true.
-c call getarg(2,jobname,idum) ! May need to replace this w/ next line
- call getarg(2,jobname)
- numargs = 1
- go to 10
- else
- print*,'Illegal option on command line'
- call stop1()
- end if
- end if
-c
-c Strip ".pmx" if necessary
-c
- ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX'))
- if (ndxpmx .gt. 0) then
- jobname = jobname(1:ndxpmx-1)
- ljob = ljob-4
- end if
-c
-c Check for existence of input file
-c
- infileq = jobname(1:ljob)//'.pmx'
- inquire(file=infileq,EXIST=fexist)
- if (.not.fexist) then
- inquire(file=jobname(1:ljob)//'.PMX',EXIST=fexist)
- if (.not.fexist) then
- print*,'Cannot find file '//infileq
- call stop1()
- else
- infileq = jobname(1:ljob)//'.PMX'
- end if
- end if
-c
-c Open a log file
-c
- open(15,file=jobname(1:ljob)//'.pml')
- call printl('This is PMX, Version '//version//', '//date)
- ljob4 = ljob
- call printl('Opening '//infileq)
- open(18,file=infileq)
-c
-c Copy input file into common buffer
-c
- ipbuf = 0
- linewcom(1) = 1
- do 8 ilbuf = 1 , maxblks
- ncomments = 0
-14 read(18,'(a)',end=9)lnholdq
- lbuf(ilbuf) = lenstr(lnholdq,128)
- if (lbuf(ilbuf) .eq. 0) then
-c
-c Blank line. Make it a single blank with length 1
-c
- lbuf(ilbuf) = 1
- lnholdq = ' '
- end if
-c
-c Now line has at least one non blank character. Check for comment
-c As of Version 260, do not copy comments into bufq
-c But need to count %'s for error messaging
-c if (lnholdq(1:1).eq.'%') go to 14
- if (lnholdq(1:1).eq.'%') then
- ncomments = ncomments+1
- go to 14
- end if
-c
-c When here, have counted all preceding comments and have a real line
-c
- if (ilbuf .gt. 1) then
- linewcom(ilbuf) = linewcom(ilbuf-1)+1+ncomments
- else
- linewcom(1) = 1+ncomments
- end if
- if (ipbuf+lbuf(ilbuf).gt.131072) then
- print*,'Too many characters in file, stopping'
- call stop1()
- end if
- bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) = lnholdq
- ipbuf = ipbuf+lbuf(ilbuf)
-8 continue
- call printl('Too many lines in input file')
- call stop1()
-9 continue
-c
-c Insert dummy line to handle input files w/o CR-LF at end.
-c
- nlbuf = ilbuf-1
-c nlbuf = ilbuf
-c bufq(ipbuf+1:ipbuf+3) = ' / '
-c lbuf(nlbuf) = 3
- close(18)
- do 6 numit = 1 , maxit
- if (optimize) call printl('Starting an iteration')
-c
-c When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0.
-c Otherwise, nbars0 is the input
-c When islast=.false., pmxb only returns poe's, otherwise does whole job
-c
- call pmxa(jobname,ljob4,isfirst,nsyst,nbars0,optimize)
- if (.not.optimize) then
- if (ismidi) then
-c
-c This was moved here from writemidi 130302 to allow midivel,bal,tran, to be
-c set up here as functions of instrument rather than iv (staff).
-c Count up staves(iv,nv) vs instruments. Store instr# for iv in iinsiv(iv)
-c
- nstaves = 0
- ivt = 0
- do 16 iinst = 1 , nm
- nstaves = nstaves+nsperi(iinst)
- do 17 ivtt = 1 , nsperi(iinst)
- ivt = ivt+1
- iinsiv(ivt) = iinst
-17 continue
- if (nstaves .eq. nv) go to 18
-16 continue
- print*,'Screwup!'
- call stop1()
-18 continue
-c
-c Set up channel numbers for midi.
-c
- numchan = 0
- do 11 iv = nv , 1 , -1
- if (twoline(iv)) then
- midchan(iv,2) = numchan
- numchan = numchan+1
- end if
- midchan(iv,1) = numchan
- numchan = numchan+1
-11 continue
-c
-c numchan will now be the number of channels, but max channel # is numchan-1
-c
-c Set up velocities, balances, and midi-transpositions
-c
- do 13 iv = nv , 1 , -1
- if (twoline(iv)) then
-c 130302 Make these functions of instrument rather than staff (iv)
-c midvelc(midchan(iv,2)) = midivel(iv)
-c midbc(midchan(iv,2)) = midibal(iv)
-c midtc(midchan(iv,2)) = miditran(iv)
- midvelc(midchan(iv,2)) = midivel(iinsiv(iv))
- midbc(midchan(iv,2)) = midibal(iinsiv(iv))
- midtc(midchan(iv,2)) = miditran(iinsiv(iv))
- end if
-c midvelc(midchan(iv,1)) = midivel(iv)
-c midbc(midchan(iv,1)) = midibal(iv)
-c midtc(midchan(iv,1)) = miditran(iv)
- midvelc(midchan(iv,1)) = midivel(iinsiv(iv))
- midbc(midchan(iv,1)) = midibal(iinsiv(iv))
- midtc(midchan(iv,1)) = miditran(iinsiv(iv))
-13 continue
- end if
-c
-c TEMPORARY!!!
-c
- write(15,*)'nlbuf: ',nlbuf
- ip1 = 1
- do 10000 ilb = 1 , nlbuf
-c write(15,'(2i5,a40,3i5)')ilb,lbuf(ilb),
-c * bufq(ip1:ip1+lbuf(ilb)-1),
-c * (ichar(bufq(ip1+lbuf(ilb)-k:ip1+lbuf(ilb)-k)),
-c * k=min(3,lbuf(ilb)),1,-1)
- ip1 = ip1+lbuf(ilb)
-10000 continue
- iplast = ip1-1
-c
-c Check to see if (1) last line is "<blank><blank>/" and (2) next to last
-c line is "/"
-c
- if (bufq(iplast+1-lbuf(nlbuf):iplast) .eq. ' /') then
- if (bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)).eq.'/') then
- print*,'Removing last line of "<blank><blank>/"'
- write(15,*)'Removing last line of "<blank><blank>/"'
- nlbuf = nlbuf-1
- end if
- end if
-c
- call pmxb(.true.,poe0,ncalls,optimize)
- if (ismidi) then
-c
-c Write midi file
-c
- open(51,file=jobname(1:ljob)//'.mid')
- if (debugmidi) open(52,file=jobname(1:ljob)//'.dbm')
- call printl(' ')
- call printl('Writing '//jobname(1:ljob)//'.mid')
- call writemidi(jobname,ljob)
- end if
- close(15)
- stop
- end if
- write(15,*)'nlbuf: ',nlbuf
- ip1 = 1
- call pmxb(.false.,poe0,ncalls,optimize)
- call poestats(nsyst,poe0,poebar0,devnorm0)
-c
-c Save initial deviation and line breaks for later comparison
-c
- if (numit .eq. 1) then
- devpmx = devnorm0
- do 20 isys = 1 , nsyst
- nbari(isys) = nbars0(isys)
-20 continue
- end if
- call sortpoe(nsyst,poe0,ipoe)
- do 1 iupord = nsyst , 1 , -1
- isysu = ipoe(iupord)
- print*,'isysu=',isysu
- write(15,*)'isysu=',isysu
-c
-c Skip if system isysu has poe0 < avg or isysd has poe0 > avg
-c
- if (poe0(isysu).lt.poebar0) go to 1
- do 5 idnord = 1 , nsyst
- isysd = ipoe(idnord)
- if (isysu.eq.isysd .or. nbars0(isysd).eq.1
- * .or. poe0(isysd).gt.poebar0) go to 5
- do 2 isyst = 1 , nsyst
- nbars(isyst) = nbars0(isyst)
- if (isyst .eq. isysu) then
- nbars(isyst) = nbars(isyst)+1
- else if (isyst .eq. isysd) then
- nbars(isyst) = nbars(isyst)-1
- end if
-2 continue
- call pmxa(jobname,ljob4,isfirst,nsyst,nbars,optimize)
- call pmxb(.false.,poe,ncalls,optimize)
- call poestats(nsyst,poe,poebar,devnorm)
- if (devnorm .lt. devnorm0) then
- devnorm0 = devnorm
- poebar0 = poebar
- do 4 isys = 1 , nsyst
- nbars0(isys) = nbars(isys)
- poe0(isys) = poe(isys)
-4 continue
- print*,'Improved with iup,idown,devnorm:',
- * isysu,isysd,devnorm0
- write(15,*)'Improved with iup,idown,devnorm:',
- * isysu,isysd,devnorm0
- write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- call sortpoe(nsyst,poe0,ipoe)
- go to 6
- end if
-5 continue
-1 continue
-c
-c If we get here, must have gone thru all switches and found nothing better,
-c so done!
-c
- go to 7
-6 continue
-7 continue
- print*,'Optimum located, numit:',numit,', ncalls:',ncalls
- write(15,*)'Optimum located, numit:',numit,', ncalls:',ncalls
- print*,'Final error:',devnorm0,', initial error:',devpmx
- write(15,*)'Final error:',devnorm0,', initial error:',devpmx
- print*,'Percentage improvement:',100.*(1-devnorm0/devpmx)
- write(15,*)'Percentage improvement:',100.*(1-devnorm0/devpmx)
- call printl('Initial bars/system:')
- write(*,'(5x,20i3)')(nbari(isys),isys=1,nsyst)
- write(15,'(5x,20i3)')(nbari(isys),isys=1,nsyst)
- call printl('Final bars/system:')
- write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- call pmxa(jobname,ljob4,.false.,nsyst,nbars0,optimize)
- call pmxb(.true.,poe0,ncalls,optimize)
- close(15)
- end
- subroutine accsym(nacc,acsymq,lacc)
- character*3 acsymq
- iacc = iand(nacc,7)
- if (iacc .eq. 1) then
- acsymq = 'fl'
- lacc = 2
- else if (iacc .eq. 2) then
- acsymq = 'sh'
- lacc = 2
- else if (iacc .eq. 3) then
- acsymq = 'na'
- lacc = 2
- else if (iacc .eq. 5) then
- acsymq = 'dfl'
- lacc = 3
- else if (iacc .eq. 6) then
- acsymq = 'dsh'
- lacc = 3
- else
- print*,'bad accidental: ',iacc
- end if
- return
- end
- subroutine addask(taskn,waskn,elaskn,
- * fixednew,scaldold,tglp1,scfac,isudsp)
- parameter (nm=24)
- logical isudsp
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comtol/ tol
- scoarg = scaldold*scfac
- if (isudsp) then
-c
-c Find which udsp we're dealing with
-c
- do 1 iudsp = 1 , nudsp
- if (abs(taskn+tglp1-tudsp(iudsp)) .lt. tol) go to 2
-1 continue
- print*,'You should note BEEE here in addask!'
- call stop1()
-2 continue
-c
-c Fixednew and scaldold must not be changed, since udsp's are already included
-c in fsyst from pmxa, and udsp don't involve scaled space..
-c
- if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then
-c
-c Must add user-defined space to what's there already.
-c
- wask(naskb) = wask(naskb)+udsp(iudsp)
- else
-c
-c This place has no other space.
-c
- naskb = naskb+1
- task(naskb) = taskn
- wask(naskb) = udsp(iudsp)
- elask(naskb) = 0.
- end if
- else
-c 130330 start
- oldwask = 0.
- oldelask = 0.
-c 130330 end
-c
-c This is a normal space, no effect if smaller than existing space
-c
- if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then
-c
-c We already put in some space at this time
-c Check if new one needs more space than old one at same time
-c
- if (waskn .gt. wask(naskb)) then
-c
-c 130330 We were double counting the larger space when it came 2nd
-c Need to fix but don't see how yet. Assume times came in order and
-c that last naskb defined spaces that need updating
-c
- oldwask = wask(naskb)
- oldelask = elask(naskb)
-c End of 130330 insertions
- naskb = naskb-1
- else
- return
- end if
- end if
- naskb = naskb+1
- task(naskb) = taskn
- wask(naskb) = waskn
- elask(naskb) = elaskn
-c 130330 start
-c fixednew = fixednew+waskn
-c scaldold = scaldold+elaskn
- fixednew = fixednew+waskn-oldwask
- scaldold = scoarg+elaskn-oldelask
-c 130330 end
- end if
- return
- end
- subroutine addblank(noteq,lnoten)
- character*8 noteq
- character*1 tchar
- tchar = noteq(1:1)
- noteq = ' '//tchar
- lnoten = 2
- return
- end
- subroutine addfb(nfb,iv,tnew,t1fb,t2fb,ulfbq,ifbadd)
- parameter (nm=24)
- integer nfb(nm)
- common /comtol/ tol
- real*4 t1fb(nm,20),t2fb(nm,20)
- character*1 ulfbq(nm,20)
- ifbadd = 1
- nfb(iv) = nfb(iv)+1
- do 1 ifb = nfb(iv)-1 , 1 , -1
- if (tnew .lt. t1fb(iv,ifb)-tol) then
- t1fb(iv,ifb+1) = t1fb(iv,ifb)
- t2fb(iv,ifb+1) = t2fb(iv,ifb)
- ulfbq(iv,ifb+1) = ulfbq(iv,ifb)
- else
- ifbadd = ifb+1
- go to 2
- end if
-1 continue
-2 continue
- t1fb(iv,ifbadd) = tnew
- ulfbq(iv,ifbadd) = 'x'
- return
- end
- subroutine addmidi(icm,nolev,iacc,midisig,time,rest,endrest)
-c subroutine addmidi(icm,nolev,iacc,isig,time,rest,endrest)
- parameter(nm=24,mv=24576)
- integer*2 mmidi,itk(25)
- integer*4 itiesav(5,100)
- character*1 notenumq
- logical endrest,eximacc,it1found
- logical rest
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
- integer*2 iinsiv
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- common /comevent/ miditime,lasttime
- common /comdiag/ n69(0:nm),n34(0:nm)
-c common /commidisig/ midisig(nm)
-c
-c Following variables are local but must be saved. I hope they are.
-c (3/18/00) With g77 they are not, so add a common block here.
-c
-c integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12)
- integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:15)
- common /comips/ ipslon,lusebl,jusebl
-c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/
- data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/
-c
-c Cancel out barline accidentals if there's a rest.
-c
- if (rest) naccbl(icm) = 0
-c
-c Special path to insert dummy rest at end of a section
-c
- if (endrest) go to 20
-c
- do 7 ion = 0 , nmidcrd
-c
-c check if this is only to get pitch of a chord note
-c
- if (notmain) go to 6
-c
-c check for rest
-c
- if (rest) then
-c
-c Will not put in a note, but must update timing
-c
- if (.not.restpend(icm)) then
-c
-c First rest in sequence, save the time
-c
- restpend(icm) = .true.
- trest(icm) = time
- else
- trest(icm) = trest(icm)+time
- end if
-c
-c Note: code checkers don't like the above due to calling addmidi(trest(icm))
-c but this only happens if rest at end of section (endrest=.true.) (called
-c from getmidi(), in which case these above lines are bypassed.
-c
- call chkimidi(icm)
- return
- end if
-c
-c time tics
-c
- if (imidi(icm).gt.0 .and. ion.eq.0) then
- idur = mgap
- else
- idur = 0
- end if
- if (restpend(icm)) then
- restpend(icm) = .false.
- idur = idur+nint(15*trest(icm))
- end if
-c
-c time to start of note
-c
- idurvar = isetvarlen(idur,nby2on)
- if (nby2on .gt. 4) then
- print*,'You got >4 bytes, something is bogus.'
- call stop1()
- end if
- imidi(icm) = imidi(icm)+1
- do 2 i = 1 , nby2on
-c
-c imidi points to cell before highest (leftmost) byte. Start with lowest byte
-c at far right, fill in backwards
-c
- mmidi(icm,imidi(icm)+nby2on-i) = mod(idurvar,256)
- if (nby2on .gt. 1) idurvar = idurvar/256
-2 continue
- imidi(icm) = imidi(icm)+nby2on-1
-c
-c Note-on signal
-c
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = 9*16+icmm(icm)
-c
-c Entry point for chord note pitch determination
-c
-6 continue
-c
-c Get midi pitch. On chord iteration, only do this first time (main note),
-c since pitch was already computed for nonmain chord notes.
-c
- if (ion .eq. 0) then
- ipsav = nolev*12./7+11
- ipsav0 = ipsav
- if (midisig .ne. 0) then
-c
-c Adjust for signature
-c
- notenumq = char(48+mod(nolev,7))
- if (midisig.ge.index('4152630',notenumq)) then
- ipsav = ipsav+1
- else if (-midisig.ge.index('0362514',notenumq)) then
- ipsav = ipsav-1
- end if
- end if
-c
-c Deal with accidentals.
-c
-c iacc 0 1 2 3 4 5 6 7
-c effect X fl sh na X dfl dsh X
-c iashft X -1 1 0 X -2 2 X
-c
- jacc = 0
- eximacc = .false.
- if (iacc .gt. 0) then
-c
-c Adjust key-sig-adjusted pitch for explicit accidental (and exit)
-c
- jacc = iashft(iacc)
- eximacc = .true.
- if (.not.relacc) jacc = jacc+ipsav0-ipsav
-c
-c (Above) Shift applies to diatonic pitch but will be added to adjusted one
-c
- else if (naccim(icm) .gt. 0) then
-c
-c Possible implicit accidental from earlier in the bar
-c Check for prior accid in this bar at this note level
-c
- do 3 kacc = 1 , naccim(icm)
- if (laccim(icm,kacc) .eq. nolev) then
- jacc = jaccim(icm,kacc)
- eximacc = .true.
- if (.not.relacc) jacc = jacc+ipsav0-ipsav
- go to 4
- end if
-3 continue
-4 continue
- end if
-c
-c Must split off the following if block from those above because chord
-c notes can cause naccim>0, forcing us to miss other chord note's
-c accross-bar-line accidental
-c
- if (naccbl(icm).gt.0 .and. .not.eximacc) then
-c
-c Possible carryover accid from prior bar (or prior same-pitch note).
-c
- do 21 kacc = 1 , naccbl(icm)
- if (laccbl(icm,kacc) .eq. nolev) then
- jacc = jaccbl(icm,kacc)
-c
-c Since we are *using* the bar-line accid, must flag it to be saved for next.
-c
- nusebl = nusebl+1
- jusebl(nusebl) = jacc
- lusebl(nusebl) = nolev
- if (.not.relacc) jacc = jacc+ipsav0-ipsav
- go to 22
- end if
-21 continue
-22 continue
- end if
- ipsav = ipsav+jacc
- end if
- if (notmain) then
- mcpitch(nmidcrd) = ipsav
-c
-c Save pitch for tie checks
-c
- if (levson(icm).eq.nolev.and..not.slmon(icm))
- * ipslon(icm) = ipsav
- else
- imidi(icm) = imidi(icm)+1
- if (ion.eq.0) then
- mmidi(icm,imidi(icm)) = ipsav
- if (levson(icm).eq.nolev.and..not.slmon(icm))
- * ipslon(icm) = ipsav
- else
- mmidi(icm,imidi(icm)) = mcpitch(ion)
- end if
- end if
- if (ion .eq. 0) then
-c
-c Only record accids for non-chords, main chord note during chord iteration
-c and chordnotes on first call but not during iteration
-c
- if (iacc.gt.0) then
-c
-c Set marker for accidental for possible continuations later this bar
-c but first check and clear earlier ones on same note.
-c
- do 23 kacc = 1 , naccim(icm)
- if (laccim(icm,kacc) .eq. nolev) then
- do 24 macc = kacc , naccim(icm)-1
- laccim(icm,macc) = laccim(icm,macc+1)
- jaccim(icm,macc) = jaccim(icm,macc+1)
-24 continue
- go to 25
- end if
-23 continue
- go to 26
-25 continue
- naccim(icm) = naccim(icm)-1
-26 continue
-c
-c Flag new accidental
-c
- naccim(icm) = naccim(icm)+1
- laccim(icm,naccim(icm)) = nolev
- jaccim(icm,naccim(icm)) = iashft(iacc)
- end if
-c
-c Bail if this is a chord note on the first call (from docrd)
-c
- if (notmain) then
- call chkimidi(icm)
- return
- end if
- end if
-c
-c Vel
-c
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = midvelc(icm)
- call chkimidi(icm)
-7 continue
-c
-c For tie checks
-c
- if (levson(icm).gt.0.and..not.slmon(icm)) imidso(icm) = imidi(icm)
-c
-c Entry point for special rests at section ends (endrest=T)
-c
-20 continue
-c
-c Now insert all the ends
-c
- do 8 ioff = 0 , nmidcrd
- if (ioff .eq. 0) then
-c
-c time to end
-c
- idur1 = nint(15*time)
- if (.not.endrest .or. miditime.eq.nint(15*trest(icm))) then
- idur = idur1-mgap
- else
- idur = idur1
- end if
-c
-c Deal with roundoff problems with 7-tuplets on half or quarters
-c
- if (idur1 .eq. 69) then
- n69(icm) = n69(icm)+1
-c if (mod(n69(icm)+6,7) .gt. 3) idur = 58
- if (mod(n69(icm)+6,7) .gt. 3) idur = idur1-mgap-1
- else if (idur1 .eq. 34) then
- n34(icm) = n34(icm)+1
- if (mod(n34(icm)+6,7) .gt. 4) idur = idur1-mgap+1
- end if
- idurvar = isetvarlen(idur,nby2off)
- if (nby2off .gt. 4) then
- print*,'You got >4 bytes, something is bogus.'
- call stop1()
- end if
- imidi(icm) = imidi(icm)+1
- call chkimidi(icm)
- do 1 i = 1 , nby2off
- mmidi(icm,imidi(icm)+nby2off-i) = mod(idurvar,256)
- if (nby2off .gt. 1) idurvar = idurvar/256
-1 continue
- imidi(icm) = imidi(icm)+nby2off-1
- else
-c
-c Inserting end of chord note, delta time is 0
-c
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = 0
- end if
-c
-c Note off
-c
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = 8*16+icmm(icm)
-c
-c Pitch
-c
- imidi(icm) = imidi(icm)+1
- if (ioff .eq. 0) then
- mmidi(icm,imidi(icm)) = ipsav
- else
- mmidi(icm,imidi(icm)) = mcpitch(ioff)
- end if
-c
-c Vel
-c
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = 0
- call chkimidi(icm)
- if (endrest) then
- return
- end if
-8 continue
- naccbl(icm) = nusebl
- if (nusebl .gt. 0) then
-c
-c Fix tables of "bar-line" accids that are saved due to consecutive notes.
-c
- do 30 kacc = 1 , nusebl
- laccbl(icm,kacc) = lusebl(kacc)
- jaccbl(icm,kacc) = jusebl(kacc)
-30 continue
- nusebl = 0
- end if
-c
-c Begin tie checks
-c
- if (slmon(icm)) then
-c
-c Prior note had a slur start
-c
- if (levson(icm).eq.levsoff(icm) .and. iacc.eq.0) then
-c
-c We have a tie! (Assumed there would be no accidental on tie-ending note)
-c Make a list of times of all events back to the one starting at imidso+1,
-c which is at or before where the tie started. Ident tie start and stop by
-c comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie)
-c Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial
-c time.
- nsav4tie = 0
- imidt = imidso(icm)
-10 nsav4tie = nsav4tie+1
- itiesav(1,nsav4tie) = igetvarlen(mmidi,icm,imidt,nbytes)
- imidt = imidt+nbytes
- do 11 j = 1 , 3
- itiesav(j+1,nsav4tie) = mmidi(icm,imidt+j)
-11 continue
- imidt = imidt+3
- if (nsav4tie .eq. 1) then
- itiesav(5,1) = itiesav(1,1)
- else
- itiesav(5,nsav4tie) = itiesav(1,nsav4tie)+
- * itiesav(5,nsav4tie-1)
- end if
- if (imidt .ne. imidi(icm)) go to 10
-c
-c Find which two pitches agree with saved slur pitch.
-c
- it1found = .false.
- do 12 it2 = 1 , nsav4tie
- if (itiesav(3,it2) .eq. ipslon(icm)) then
- if (it1found) go to 13
- it1 = it2
- it1found = .true.
- end if
-12 continue
- call printl(
- * 'Program error, tied notes, send source to Dr. Don')
- it1 = nsav4tie+1
- it2 = nsav4tie+1
-13 continue
-c
-c List the positions we want to keep
-c
- jsav = 0
- do 14 isav = 1 , nsav4tie
- if (isav.eq.it1 .or. isav.eq.it2) go to 14
- jsav = jsav+1
- itk(jsav) = isav
-14 continue
- nsav4tie = nsav4tie-2
-c
-c Now dump events it1 & it2, recompute times, restack mmidi.
-c
- imidi(icm) = imidso(icm)
- do 15 isav = 1 ,nsav4tie
- if (isav .eq. 1) then
- idurvar = isetvarlen(itiesav(5,itk(isav)),nbytes)
- else
- idurvar = isetvarlen(itiesav(5,itk(isav))-
- * itiesav(5,itk(isav-1)),nbytes)
- end if
- imidi(icm) = imidi(icm)+1
- do 16 i = 1 , nbytes
- mmidi(icm,imidi(icm)+nbytes-i) = mod(idurvar,256)
- if (nbytes .gt. 1) idurvar = idurvar/256
-16 continue
- imidi(icm) = imidi(icm)+nbytes-1
- do 17 i = 2 , 4
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = itiesav(i,itk(isav))
-17 continue
-15 continue
- end if
- slmon(icm) = .false.
- levsoff(icm) = 0
- if (.not.dbltie) levson(icm) = 0
- end if
- if (levson(icm).gt.0) slmon(icm) = .true.
- if (nmidcrd .gt. 0) nmidcrd = 0
- call chkimidi(icm)
- return
- end
- subroutine addstr(notexq,lnote,soutq,lsout)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- character*(*) notexq
- character*80 soutq
- if (lsout+lnote .gt. 72) then
- if (islast) write(11,'(a)')soutq(1:lsout)//'%'
- lsout = 0
- end if
- if (lsout .gt. 0) then
- soutq = soutq(1:lsout)//notexq(1:lnote)
- else
- soutq = notexq(1:lnote)
- end if
- lsout = lsout+lnote
- return
- end
- subroutine adjusteskz(ib,istart,poenom)
-c
-c For block ib, this adds accidental spaces to eskz, for use in getting
-c length of xtup bracket and slopes of brackets and beams.
-c
- parameter (nm=24)
- common /comas1/ naskb,task(40),wask(40),elask(40)
- integer*4 istart(80)
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- common /comeskz2/ eskz2(nm,200)
- common /comtol/ tol
- common /comntot/ ntot
- inmin = istart(ib)+1
- do 10 iaskb = 1 , naskb
- if (task(iaskb) .lt. to(istart(ib))-tol) go to 10
- eskadd = wask(iaskb)/poenom-elask(iaskb)
- do 11 in = inmin , ntot
- if (to(in) .gt. task(iaskb)-tol) then
- eskz2(ivxo(in),ipo(in)) = eskz2(ivxo(in),ipo(in))+eskadd
- if (abs(to(in)-task(iaskb)).lt. tol) inmin=inmin-1
- else
- inmin = inmin+1
- end if
-11 continue
-10 continue
- return
- end
- subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0)
- logical figbass,ispoi,topmods,istype0,done,isbbm
- common /comhsp/ hpttot(176)
- common /compoi/ ispoi
- common /combbm/ isbbm
- common /comas3/ ask(2500),iask,topmods
- character*40 pathnameq
- character*44 basenameq
- character*1 sq,chax
- character*129 outq
- sq = chax(92)
- open(12,file=pathnameq(1:lpath)//basenameq(1:lbase)//'.tex')
-c
-c Transfer first 5 lines of main internal TeX file
-c
- do 11 il = 1 , 5
- call moveln(11,12,done)
-11 continue
- if (istype0) then
-c
-c Transfer literal TeX stuff from special scratch file
-c
- rewind(17)
-10 call moveln(17,12,done)
- if (.not.done) go to 10
- close(17)
- end if
-c
-c Transfer next 2 lines from main scratch file
-c
- do 3 il = 1 , 2
- call moveln(11,12,done)
-3 continue
- if (ispoi) write(12,'(a)')sq//'input musixpoi'
- if (isbbm) write(12,'(a)')sq//'input musixbbm'
- if (figbass) then
-c
-c Transfer .fig data from scratch (unit 14) into external .tex (unit 12)
-c
-4 call moveln(14,12,done)
- if (.not.done) go to 4
- close(14)
- end if
- iask = 0
- ihs = 0
-1 read(11,'(a129)',end=999)outq
-c
-c Hardspaces.
-c
- if (outq(1:5) .eq. sq//'xard') then
- ihs = ihs+1
- outq(2:2) = 'h'
- write(outq(12:15),'(f4.1)')hpttot(ihs)
- lenout = 19
- go to 9
- end if
-c
-c This part hard-wires ask's into new .tex file as ast's
-c
-2 indxask = index(outq,sq//'ask')
- if (indxask .ne. 0) then
- iask = iask+1
- call putast(ask(iask),indxask,outq)
- go to 2
- end if
- lenout = llen(outq,129)
-9 continue
- write(12,'(a)')outq(1:lenout)
-c
-c If this is the line with "readmod", check for topmods.
-c
- if (topmods .and. outq(2:8).eq.'readmod') then
- topmods = .false.
- rewind(16)
- do 7 il = 1 , 1000
- read(16,'(a129)',end=8)outq
- lenout = llen(outq,129)
-c
-c We inserted the '%' in subroutine littex, to guarantee including blank.
-c
- write(12,'(a)')outq(1:lenout)
-7 continue
-8 continue
- close(16)
- end if
- go to 1
-999 close(11)
- close(12)
- return
- end
- subroutine backfill(iunit,oldq,lenold,newq,lennew)
-c
-c In iunit, looks backward for oldq, overwrites newq
-c Safest if both are same length!
-c
- character*128 lineq(200),nowq
- character*(*) oldq,newq
- linesback = 0
-1 continue
- backspace(iunit)
- read(iunit,'(a)')nowq
- ndx = index(nowq,oldq(1:lenold))
-c
-c Save the line just read
-c
- linesback = linesback+1
- lineq(linesback) = nowq
- if (ndx .eq. 0) then
- backspace(iunit)
- go to 1
- end if
-c
-c If here, it's replacement time.
-c
- lineq(linesback) = nowq(1:ndx-1)//newq(1:lennew)
- * //nowq(ndx+lenold:128)
- backspace(iunit)
- do 2 line = linesback , 1 , -1
- write(iunit,'(a128)')lineq(line)
-2 continue
- return
- end
- subroutine beamend(notexq,lnote)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq,ulqq,chax
- logical beamon,firstgulp,figbass,figchk,flipend,btest,
- * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2,multbj1
- common /comoct/ noctup
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- character*4 tempq
- character*8 noteq
- character*79 notexq
- ip = ipo(jn)
- multip = iand(mult(ivx,ip),15)-8
- lnote = 0
- if (ixrest(ivx) .eq. 4) then
-c
-c This is the LAST note in the xtup (i.e., all rests before). Make single.
-c
- nodur(ivx,ip) = 2**(4-multip)
- call notex(notexq,lnote)
- ixrest(ivx) = 0
- return
- end if
- nole = nolev(ivx,ip)
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ip),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ip),31)) then
- nole = nole + 1
- end if
-c
-c Terminate indented beams for 2-note tremolo if needed
-c
- if (btest(irest(ivx,ip-1),2) .and.
- * igetbits(irest(ivx,ip-1),2,5) .gt. 0) then
- nindent = igetbits(irest(ivx,ip-1),2,5)
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
- addoff = -1-.5*nindent
- else
- addoff = 1+.5*nindent
- endif
-c addoff = addoff+(.595-.065*abs(islope(ivx)))*islope(ivx)
- addoff = addoff+.0822*islope(ivx)
- if (addoff .lt. -.05) then
- write(tempq,'(f4.1)')addoff
- else
- write(tempq,'(f4.2)')addoff
- end if
- notexq = sq//'raise'//tempq(1:4)//sq//'internote'//sq//'hbox{'
- * //sq//'loffset{.7}{'//sq//'tb'//ulq(ivx,ibmcnt(ivx))//
- * '0}}'
- lnote = 46
- end if
- if (.not.drawbm(ivx)) then
-c
-c Xtuplet with no beam, just put in the right kind of note
-c
- if (btest(irest(ivx,ip),0)) then
-c
-c Rest at end of unbeamed xtup
-c
- lnote = 3
- if (btest(islur(ivx,ip),29)) then
- notexq = sq//'sk'
-c
-c 180106 There was a problem with nolev(ivx,ip) not being set to 0 for
-c a blank rest ending xtup, but hopefully returning from here will handle it.
-c
- return
- else if (multip .eq. 0) then
- notexq = sq//'qp'
- else if (multip .eq. -1) then
- notexq = sq//'hp'
- else if (multip .eq. 1) then
- notexq = sq//'ds'
- else if (multip .eq. 2) then
- notexq = sq//'qs'
- else
- notexq = sq//'hs'
- end if
-c
-c 180106 Deal with possible level tweak
-c
- nole = mod(nolev(ivx,ip)+50,100)-50
- if (nole .ne. 0) then
- if (abs(nole) .lt. 10) then
- noteq = chax(48+abs(nole))
- lnoten = 1
- else
- write(noteq(1:2),'(i2)')abs(nole)
- lnoten = 2
- end if
- if (nole .gt. 0) then
- notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote'
- * //notexq(1:lnote)
- else
- notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote'
- * //notexq(1:lnote)
- end if
- lnote = 16+lnoten+lnote
- end if
- return
- end if
- if (btest(islur(ivx,ip),30)) then
-c
-c Forced stem direction
-c
- ndsav = nodur(ivx,ip)
- nodur(ivx,ip) = 2**(4-multip)
- if (btest(nacc(ivx,ip-1),27))
- * nodur(ivx,ip)=nodur(ivx,ip)/2
- call notex(notexq,lnote)
- nodur(ivx,ip) = ndsav
- else
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
-c
-c To reduce confusion due to this early update of lnote, do it
-c below, separately in each case/
-c lnote = lnoten+3
- if (.not.btest(nacc(ivx,ip-1),27)) then
-c
-c Prior note is not regular-dotted
-c
- if (btest(irest(ivx,ip-1),2) .and.
- * igetbits(irest(ivx,ip-1),2,5) .gt. 0) then
-c
-c Unbeamed tremolo with indented beams. Put termination in right here
-c
- nindent = igetbits(irest(ivx,ip-1),2,5)
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
- addoff = -1-.5*nindent
- else
- addoff = 1+.5*nindent
- endif
-c
-c Is there an islope here, for unbeamed?
-c
- if (addoff .lt. -.05) then
- write(tempq,'(f4.1)')addoff
- else
- write(tempq,'(f4.2)')addoff
- end if
- notexq = sq//'raise'//tempq(1:4)//sq//'internote'//sq//
- * 'hbox{'
- * //sq//'loffset{.7}{'//sq//'tb'//ulq(ivx,ibmcnt(ivx))//
- * '0}}'
- lnote = 46
- end if
- if (multip .eq. 0) then
- if (btest(irest(ivx,ip-1),2) .and.
- * nodur(ivx,ip).gt.24) then
-c
-c 2nd note of unbeamed half-note trem; make open
-c But it's not clear if unbeamed half-note tremolo is Kosher,
-c so don't worry about stem lengths here now.
-c
- if (lnote .eq. 0) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
- else
- notexq = notexq(1:46)//
- * sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
- lnote = 46
- end if
- else
- if (btest(irest(ivx,ip-1),2) .and.
- * nodur(ivx,ip).eq.24 .or. nodur(ivx,ip).eq.12) then
-c
-c Need a dot.
-c
- lnote = 46
- if (lnoten .eq. 1) then
- noteq = ' '//noteq(1:1)
- lnoten = 2
- end if
-c
-c Insert stemlength stuff here for unbeamed dotted tremolo.
-c May later combine with below to avoid repeat. But need to
-c return to normal stem length after note is set.
-c
- nindent = igetbits(irest(ivx,ip-1),2,5)
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
- slen = (4.5+nindent+nolev1(ivx)-nole
- * +1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7)
- * *islope(ivx)/slfac)*.6667
- else
- slen = (4.5+nindent-nolev1(ivx)+nole
- * -1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7)
- * *islope(ivx)/slfac)*.6667
- end if
- write(tempq,'(f4.1)')slen
- notexq = sq//'slx{'//tempq//'}'//notexq(1:lnote)
- lnote = lnote+10
- end if
-c
-c Next steps are a historical kluge to distinguish dotted unbeamed 2-note trem
-c (needs \qup) from normal xtup on dotted note (eg e44dx2 f, wants no dot)
-c
- if (btest(irest(ivx,ip-1),2)) then
- if (lnote .eq. 0) then
-c notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//'p'
- * //noteq(1:lnoten)
- else
- notexq = notexq(1:lnote)//sq//'q'
-c * //ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
- * //ulq(ivx,ibmcnt(ivx))//'p'//noteq(1:lnoten)
- end if
-c lnote = lnote+3+lnoten
- lnote = lnote+4+lnoten
- else
- if (lnote .eq. 0) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
- * //noteq(1:lnoten)
- else
- notexq = notexq(1:lnote)//sq//'q'
- * //ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
- end if
- lnote = lnote+3+lnoten
- end if
- if (btest(irest(ivx,ip-1),2) .and.
- * nodur(ivx,ip).eq.24 .or. nodur(ivx,ip).eq.12) then
- notexq = notexq(1:lnote)//sq//'slz'
- lnote=lnote+4
- end if
- end if
- else if (btest(irest(ivx,ip-1),2)) then
-c
-c 2nd note of unbeamed quarter or 8th trem; make quarter note
-c Get stemlength change
-c
- lnote = 46
- nindent = igetbits(irest(ivx,ip-1),2,5)
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
- slen = (4.5+nindent+nolev1(ivx)-nole
- * +1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7)
- * *islope(ivx)/slfac)*.6667
- else
- slen = (4.5+nindent-nolev1(ivx)+nole
- * -1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7)
- * *islope(ivx)/slfac)*.6667
- end if
- write(tempq,'(f4.1)')slen
- notexq = notexq(1:46)//sq//'slx{'//tempq//'}'
- lnote = lnote+10
-c if (lnote .eq. 0) then
-c notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
-c else
-c notexq = notexq(1:46)//
-c * sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
-c end if
-c
-c
-c Check for dotted unbeamed tremolo
-c
- if (abs(nodur(ivx,ip)/12.-nodur(ivx,ip)/12).lt..001) then
-c
-c Need a dot
-c
- if (lnoten .eq. 1) then
- noteq = ' '//noteq(1:1)
- lnoten = 2
- end if
- if (lnote .eq. 0) then
- notexq = sq//'pt'//noteq(1:lnoten)
- else
- notexq = notexq(1:lnote)//sq//'pt'//noteq(1:lnoten)
- end if
- lnote = lnote+3+lnoten
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- if (lnoten .eq. 1) then
- noteq = ' '//noteq(1:1)
- lnoten = 2
- end if
- end if
- notexq = notexq(1:lnote)//
- * sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
-c * //sq//'stemcut'
- * //sq//'slz'
-c lnote=lnote+3+lnoten+8
- lnote=lnote+3+lnoten+4
- else if (multip .eq. -1) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
- lnote = lnoten+3
- else if (multip .eq. 1) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
- lnote = lnoten+3
- else if (multip .eq. 2) then
- notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
- lnote = lnoten+4
- else if (multip .eq. 3) then
- notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
- lnote = lnoten+5
- else if (multip .eq. -2) then
- notexq = sq//'wh'//noteq(1:lnoten)
- lnote = lnoten+3
- else if (multip .eq. -3) then
- notexq = sq//'breve'//noteq(1:lnoten)
- lnote = lnoten+6
- else
- print*
- print*,'(Error in beamend, send source to Dr. Don)'
- call stop1()
- end if
- else
-c
-c Prior note is regular-dotted so this one is halved
-c
- lnote = lnoten+3
- if (multip .eq. 0) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. -1) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. -2) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. 1) then
- notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq
- lnote = lnoten+4
- else if (multip .eq. 2) then
- notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq
- lnote = lnoten+5
- end if
- end if
- end if
- return
- end if
-c
-c End of block for unbeamed. Problem if beamed but ends w/ rest. Try just
-c skipping the call in that case.
-c
- if (.not.btest(irest(ivx,ip),0)) then
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- end if
-c call notefq(noteq,lnoten,nole,ncmid(iv,ip))
-c lnote = 0
-c
-c New way, with flipend, which was computed in beamstrt.
-c
- if (flipend(ivx) .and. btest(ipl(ivx,ip),30)) then
- ulq(ivx,ibmcnt(ivx)) = chax(225-ichar(ulq(ivx,ibmcnt(ivx))))
- flipend(ivx) = .false.
- end if
- if (ip .gt. ibm1(ivx,ibmcnt(ivx))) then
-c
-c This is not a one-noter from beam-jump. Check if multiplicity has increased
-c
- if (btest(irest(ivx,ip-1),0)) then
-c
-c Prior note is a rest, check one before that
-c
- mp = iand(mult(ivx,ip-2),15)-8
- else
- mp = iand(mult(ivx,ip-1),15)-8
- end if
- if (multip .gt. mp) then
-c
-c Assume 1-3, 2-3, or 1-2
-c
- do 2 imp = multip , mp+1 , -1
- call ntrbbb(imp,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
-2 continue
- else if (btest(nacc(ivx,ip-1),27)) then
-c
-c 2nd member of dotted xtup
-c
- call ntrbbb(multip+1,'t',
- * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
- end if
- end if
-c
-c Beam termination and direction analysis
-c
- if (btest(irest(ivx,ip),23) .and. .not.isbjmp) then
-c
-c This is the end of the first segment in a jump-beam. ivbj1=ivx will be number
-c of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the
-c voice of the 2nd part of jumped beam. (May need special treatment for
-c multi-segment jump-beams
-c
- isbjmp = .true.
- ivbj1 = ivx
- multbj1 = iand(15,mult(ivx,ip)-8)
- ivbj2 = 0
- end if
- if (.not.btest(irest(ivx,ip),23)) then
-c
-c This is either a normal beamend or end of a sequence of jump-beam segments,
-c (170409) or rest at end of xtup
-c so some sort of termination is required
-c
- ulqq = ulq(ivx,ibmcnt(ivx))
- if (.not.isbjmp .or. ivx.ne.ivbj2) then
- if (btest(irest(ivx,ip),0)) then
-c
-c Xtup ends with rest
-c
- if (multip .eq. 1) then
- notexq = sq//'ds'
- lnote = 3
- else if (multip .eq. 2) then
- notexq = sq//'qs'
- lnote = 3
- else if (multip .eq. 3) then
- notexq = sq//'hs'
- lnote = 3
- end if
-c
-c 170801 Borrowed from main rest entry way down below to get level adjustment:
-c BUT nole is like 102, not 2, so subtracted 100 for nole. Why different???
-c "... Now raise if necc."
-c
- if (btest(islur(ivx,ip),29)) then
-c
-c Blank rest
-c
- notexq = sq//'sk'
- lnote = 3
- else if (nole .ne. 0) then
-c
-c Bandaid. Odd case with rests in xtups + 2 voices where came thru here with
-c nolev=-4 but expected 100+/-. Try to fix.
-c
- if (abs(nole).lt.30) nole = 100+nole
-c
- if (abs(nole-100) .lt. 10) then
- noteq = chax(48+abs(nole-100))
- lnoten = 1
- else
- write(noteq(1:2),'(i2)')abs(nole-100)
- lnoten = 2
- end if
-c ??? if (nole .gt. 0) then
- if (nole .gt. 100) then
- notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote'
- * //notexq(1:lnote)
- else
- notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote'
- * //notexq(1:lnote)
- end if
- lnote = 16+lnoten+lnote
- end if
- return
- else
-c
-c Normal termination
-c
- call ntrbbb(1,'t',ulqq,mod(ivx,24),notexq,lnote)
- end if
- else
-c
-c Terminate a sequence of jump-beam segments.
-c
- ulqq = chax(225-ichar(ulqq))
- call ntrbbb(1,'t',ulqq,mod(ivbj1,24),notexq,lnote)
- end if
- end if
-c
-c Check for end of 2nd seg of staff-jump xtup chord blank rest
-c
-c if (isbjmp.and.ivx.eq.ivbj2
- if (isbjmp
- * .and.btest(islur(ivx,ip),29)) then
- notexq = notexq(1:lnote)//sq//'sk'
- return
- end if
-c
-c And now the note, checking for open-head beamed tremolo
-c
- if (btest(irest(ivx,ip-1),2)) then
-c
-c Check for dotted tremolo
-c
- if (abs(nodur(ivx,ip)/12.-nodur(ivx,ip)/12).lt..001) then
-c
-c Need a dot
-c
- if (nodur(ivx,ip).eq.24 .or. nodur(ivx,ip).eq.12) then
-c
-c Solid notehead
-c
- notexq = notexq(1:lnote)//sq//'qbp'
- else
-c
-c Assuming open notehead and nodur = 48
-c
- notexq = notexq(1:lnote)//sq//'hbp'
- end if
- lnote = lnote+4
- else
- if (nodur(ivx,ip).eq.32 .or. nodur(ivx,ip).eq.48) then
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'hb'
- else
- notexq = sq//'hb'
- end if
- else
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'qb'
- else
- notexq = sq//'qb'
- end if
- end if
- lnote = lnote+3
- end if
- else
-c
-c No tremolo
-c
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'qb'
- else
- notexq = sq//'qb'
- end if
- lnote = lnote+3
- end if
- isdotm = .false.
- if (.not.vxtup(ivx)) then
- if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then
- if (.not.btest(iornq(ivx,ip),13)) then
- notexq = notexq(1:lnote)//'p'
- else
- notexq = notexq(1:lnote)//'m'
- isdotm = .true.
- end if
- lnote = lnote+1
- end if
- end if
-c
-c 5/25/08 Allow >12
-c 5/9/10 Up to 24; replace 24 with 0
-c
- if (.not.(isbjmp.and.ivx.eq.ivbj2)) then
- call istring(mod(ivx,24),tempq,len)
- else
- call istring(mod(ivbj1,24),tempq,len)
- end if
- if (isbjmp .and. ivx.eq.ivbj2
- * .and..not.btest(irest(ivx,ip),23)) isbjmp=.false.
- notexq = notexq(1:lnote)//tempq(1:len)
- lnote = lnote+len
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (isdotm) then
- if (lnoten .eq. 1) then
- notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- return
- end
- subroutine beamid(notexq,lnote)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq,ulqq,chax
- logical beamon,firstgulp,figbass,figchk,flipend,btest,
- * isfig,vxtup,isdotm,isbjmp,bar1syst,isdotted,isbj2,drawbm
- character*79 notexq
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2,multbj1
- common /comoct/ noctup
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- character*8 noteq
- character*4 tempq
- lnote = 0
- ip = ipo(jn)
- nole = nolev(ivx,ip)
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ip),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ip),31)) then
- nole = nole + 1
- end if
- if (.not.btest(irest(ivx,ip),0)) then
- multip = iand(mult(ivx,ip),15)-8
-c if (btest(islur(ivx,ip-1),3)) multip = multip+1
-c
-c (Above test OK since must have ip>1). Double dotted note preceding
-c
-c Move the following, because can't ask for note until after checking for
-c embedded xtup with number, due to ordering/octave feature.
-c
-c call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
- end if
- if (btest(irest(ivx,ip),28)) vxtup(ivx) = .true.
- if (vxtup(ivx)) then
-c
-c In an xtup
-c
- if (btest(irest(ivx,ip),0)) then
-c
-c Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK
-c
- nodur(ivx,ip) = 2**(4-(iand(mult(ivx,ip),15)-8))
- call notex(notexq,lnote)
-c
-c Re-zero so next note does not get confused
-c
- nodur(ivx,ip) = 0
- return
- end if
- if (.not.drawbm(ivx)) then
-c
-c Xtuplet with no beam, just put in the right kind of note
-c
- if (btest(islur(ivx,ip),30)) then
-c
-c Forced stem direction
-c
- ndsav = nodur(ivx,ip)
- nodur(ivx,ip) = 2**(4-multip)
- if (btest(nacc(ivx,ip),19) .or.
- * btest(nacc(ivx,ip),27)) then
- nodur(ivx,ip)=3*nodur(ivx,ip)/2
- else if (btest(nacc(ivx,ip-1),27)) then
- nodur(ivx,ip)=nodur(ivx,ip)/2
- end if
- call notex(notexq,lnote)
- nodur(ivx,ip) = ndsav
- else
-c
-c Use ulq for stem direction
-c
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- lnote = 3
- if (.not.btest(nacc(ivx,ip-1),27)) then
-c
-c Prior note of xtup is not regular-dotted
-c
- if (multip .eq. 0) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -1) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 1) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 2) then
- notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))
- lnote = 4
- else if (multip .eq. 3) then
- notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))
- lnote = 5
- else if (multip .eq. -2) then
- notexq = sq//'wh'
- end if
- if (btest(nacc(ivx,ip),27)) then
-c
-c This xtup note is regular dotted non-beamed xtup
-c
-c notexq = notexq(1:3)//'p'
-c lnote = 4
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
- else
-c
-c Prior note of xtup is regular-dotted so this one is halved
-c
- if (multip .eq. 2) then
- notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))
- lnote = 5
- else if (multip .eq. 1) then
- notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))
- lnote = 4
- else if (multip .eq. 0) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -1) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -2) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
- end if
- end if
- notexq = notexq(1:lnote)//noteq
- lnote = lnote+lnoten
- end if
- return
- else if (nodur(ivx,ip).eq.0) then
-c
-c In the beamed xtup but not the last note
-c
- if (nodur(ivx,ip-1).gt.0) then
-c
-c Embedded Xtup, mult>0, starts here. Put in number if needed
-c
- nxtinbm(ivx) = nxtinbm(ivx)+1
- iud = 1
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') iud = -1
-c
-c Get ip#, notelevel of middle note (or gap) in xtup
-c
- ipmid = ip+ntupv(ivx,nxtinbm(ivx))/2
- xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud,
- * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8)
- if (mod(ntupv(ivx,nxtinbm(ivx)),2).eq.0) xnlmid = (xnlmid+
- * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud,
- * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2
- iflop = 0
- if (abs(xnlmid-ncmid(iv,ip)).lt.3.) iflop = -iud
- iup = iud+2*iflop
- if (btest(irest(ivx,ip),14)) then
- iup = -iup
- iflop = 0
- if (iud*iup .lt. 0) iflop = iup
- end if
-c
-c Place number if needed
-c
- if (.not.btest(islur(ivx,ip),31)) then
- mprint = igetbits(nacc(ivx,ip),5,22)
- if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx))
- call putxtn(mprint,iflop,multip,iud,wheadpt,poenom,
- * nolev1(ivx),islope(ivx),slfac,
- * xnlmid,islur(ivx,ip),lnote,notexq,ncmid(iv,ip),nlnum,
- * eloff(ivx,nxtinbm(ivx)),iup,irest(ivx,ip),
- * mult(ivx,ip),.false.)
- end if
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- else
-c
-c Intermediate note of xtup
-c
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- end if
- else
-c
-c Last note of xtup (but not last note of beam!)
-c
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- end if
- else if (btest(irest(ivx,ip),0)) then
- call notex(notexq,lnote)
- return
- else
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- end if
-c
-c Check for string of rests up to and including last note in xtup.
-c
-c Replace next 2 lines to keep from doing this block
-c when in second part of staff-jumping chordal xtup. This fix could
-c break some unaccounted non-chordal staff-jum xtup situations.
-c if (vxtup(ivx) .and. btest(irest(ivx,ip+1),0) .and.
-c * .not.btest(irest(ivx,ip),0)) then
- if (vxtup(ivx) .and. btest(irest(ivx,ip+1),0) .and.
- * .not.btest(irest(ivx,ip),0) .and.
- * .not.(isbjmp.and.ivx.eq.ivbj2)) then
-c
-c This note is not a rest but next is a rest. Do rests continue to
-c end of xtup, where nodur>0
-c
- do 3 ipnow = ip+1 , ip+24
- if (nodur(ivx,ipnow).gt.0) go to 4 ! This is last of xtup
- if (.not.btest(irest(ivx,ipnow+1),0)) go to 5 ! Next is not rest
-c
-c If I don't go to 5, know next note IS a rest!
-c
-3 continue
-4 continue
- call ntrbbb(1,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
- notexq = notexq(1:lnote)//sq//'qb'
- lnote = lnote+3
- call istring(ivx,tempq,len)
- notexq = notexq(1:lnote)//tempq(1:len)
- lnote = lnote+len
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- return
-5 continue
-c
-c Check if multiplicity changes in a way requiring action,
-c unless (160211) it's blank rest on start of 2nd seg of joined beam
-c
- else if(.not.btest(irest(ivx,ip-1),24)
- * .or..not.btest(islur(ivx,ip-1),29)) then
- ipleft = ip-1
- if (btest(irest(ivx,ipleft),0)) ipleft = ipleft-1
- if (.not.btest(islur(ivx,ipleft),20)) then
- multl = iand(15,mult(ivx,ipleft))-8
- else
- multl = 1
- end if
- mub = multip - multl
- ipright = ip+1
- if (btest(irest(ivx,ipright),0)) ipright = ipright+1
- if (.not.btest(islur(ivx,ip),20)) then
- multr = iand(15,mult(ivx,ipright))-8
- else
- multr = 1
- end if
- mua = multr-multip
- if (mub.gt.0 .or. mua .lt. 0) then
-c
-c Multiplicity has increased from left or will decrease to right. Need action.
-c
- if (isbjmp .and. ivx.eq.ivbj2) then
- ivb = ivbj1
- ulqq = chax(225-ichar(ulq(ivx,ibmcnt(ivx))))
- else
- ivb = ivx
- ulqq = ulq(ivx,ibmcnt(ivx))
- end if
- if (mua .ge. 0) then
- call ntrbbb(multip,'n',ulqq,ivb,notexq,lnote)
-c
-c Test for next note being blank rest, assuming staff-crossing
-c xtup chord
-c
- else if (multl .ge. multr .and.
- * .not.btest(islur(ivx,ip+1),29)) then
- do 1 im = multip , 1+multr, -1
- call ntrbbb(im,'t',ulqq,ivb,notexq,lnote)
-1 continue
-c else
-c Test for next note being blank rest, assuming staff-crossing
-c xtup chord
-c
- else if (.not.btest(islur(ivx,ip+1),29)) then
- do 2 im = 1+multr, multip
- call ntrbbb(im,'r',ulqq,ivb,notexq,lnote)
-2 continue
- call ntrbbb(multr,'n',ulqq,ivb,notexq,lnote)
- end if
- else if (ip .gt. 1) then
-c
-c Check for 2nd member of dotted xtup
-c
- if (btest(nacc(ivx,ip-1),27)) call ntrbbb(multip+1,'t',
- * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
- end if
- end if
-c
-c Now put in the note
-c
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'qb'
- else
- notexq = sq//'qb'
- end if
- lnote = lnote+3
- isdotm = .false.
- if (isdotted(nodur,ivx,ip)) then
-c
-c rule out ')'
-c
- if (.not.btest(iornq(ivx,ip),13)) then
- if (.not.btest(islur(ivx,ip),3)) then
- notexq = notexq(1:lnote)//'p'
- else
-c
-c Double dot
-c
- notexq = notexq(1:lnote)//'pp'
- lnote = lnote+1
- end if
- else
- notexq = notexq(1:lnote)//'m'
- isdotm = .true.
- end if
- lnote = lnote+1
- else if (btest(nacc(ivx,ip),19)
- * .or. btest(nacc(ivx,ip),27)) then
-c
-c Special dotted notation for 2:1 xtup, or normal dot in xtup
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
-c
-c 5/25/08 Allow >12
-c
- if (.not.(isbjmp.and.ivx.eq.ivbj2)) then
-c call istring(mod(ivx,12),tempq,len)
- call istring(mod(ivx,24),tempq,len)
- else
-c call istring(mod(ivbj1,12),tempq,len)
- call istring(mod(ivbj1,24),tempq,len)
- end if
- notexq = notexq(1:lnote)//tempq(1:len)
- lnote = lnote+len
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (isdotm) then
- if (lnoten .eq. 2) then
- notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- return
- end
- subroutine beamn1(notexq,lnote)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,btest,
- * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm
- logical gotnote
- common /comoct/ noctup
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2,multbj1
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*8 noteq,tempq,numq
- character*79 notexq
- gotnote = .false.
- lnoten = 0
- ip1 = ipo(jn)
- multip = iand(15,mult(ivx,ip1))-8
- if (.not.drawbm(ivx) .and. btest(irest(ivx,ip1),0)) then
- lnote = 0
-c
-c The rest was already written in beamstrt, so just get out of here
-c
- return
- end if
- nole = nolev(ivx,ipo(jn))
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ipo(jn)),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ipo(jn)),31)) then
- nole = nole + 1
- end if
- if (vxtup(ivx) .and. .not.drawbm(ivx)) then
-c
-c Xtuplet with no beam, just put in the right kind of note
-c
- if (btest(islur(ivx,ip1),30)) then
-c
-c Forced stem direction
-c
- ndsav = nodur(ivx,ip1)
- nodur(ivx,ip1) = 2**(4-multip)
- if (btest(nacc(ivx,ip1),19) .or.
- * btest(nacc(ivx,ip1),27)) nodur(ivx,ip1)=3*nodur(ivx,ip1)/2
- call notex(notexq,lnote)
- nodur(ivx,ip1) = ndsav
- else
- call notefq(noteq,lnoten,nole,ncmid(iv,ip1))
- gotnote = .true.
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- lnote = 3
- if (multip .le. 0) then
- if ((btest(irest(ivx,ip1),2) .and.
- * nodur(ivx,ip1+1).ge.32)
- * .or. multip .eq. -1) then
-c
-c 1st note of unbeamed half-note trem; make open
-c
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -2) then
- notexq = sq//'wh'
- else
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
- end if
-c
-c Check for dot
-c
- if (btest(irest(ivx,ip1),2) .and.
- * abs(nodur(ivx,ip1+1)/12.-nodur(ivx,ip1+1)/12).lt..001) then
-c
-c Need a dot. already called addblank for noteq
-c
- if (lnote .eq. 0) then
- notexq = sq//'pt'//noteq(1:lnoten)
- lnote = 3+lnoten
- else
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
- end if
-c
-c Insert the stemlength calcs here for dotted, unbeamed.
-c Later may combine with below to avoid repeat.
-c
- if (btest(irest(ivx,ip1),2)) then
- nindent = igetbits(irest(ivx,ip1),2,5)
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
- slen = (4.5+nindent+nolev1(ivx)-nole
- * -.4*islope(ivx)/slfac)*.6667
- else
- slen = (4.5+nindent-nolev1(ivx)+nole
- * +.4*islope(ivx)/slfac)*.6667
- end if
- write(tempq,'(f4.1)')slen
- notexq = sq//'slx{'//tempq(1:4)//'}'//
- * notexq(1:lnote)
- lnote = lnote+10
- end if
- else if (btest(irest(ivx,ip1),2)) then
-c
-c 1st note of unbeamed quarter or 8th trem, make a quarter note
-c
-c Stem length calcs here. The .2 factor is empirical, but
-c slfac accounts for musicsize.
-c
- nindent = igetbits(irest(ivx,ip1),2,5)
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
- slen = (4.5+nindent+nolev1(ivx)-nole
- * -.4*islope(ivx)/slfac)*.6667
- else
- slen = (4.5+nindent-nolev1(ivx)+nole
- * +.4*islope(ivx)/slfac)*.6667
- end if
- write(tempq,'(f4.1)')slen
- notexq = sq//'slx{'//tempq(1:4)//'}'//
- * sq//'q'//ulq(ivx,ibmcnt(ivx))
- lnote = 13
-c
-c Check for dotted 2-note trem; prepend dot to notexq if needed
-c
- if (nodur(ivx,ip1+1).eq.12 .or.
- * nodur(ivx,ip1+1).eq.24) then
- if (lnoten .eq. 1) then
- noteq = ' '//noteq(1:1)
- lnoten = 2
- end if
- notexq = sq//'pt'//noteq(1:lnoten)//notexq(1:lnote)
- lnote = lnote+3+lnoten
- call notefq(noteq,lnoten,nole,ncmid(iv,ip1))
- gotnote = .true.
- if (lnoten .eq. 1) then
- noteq = ' '//noteq(1:1)
- lnoten = 2
- end if
- end if
- else if (multip .eq. -1) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 1) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 2) then
- notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))
- lnote = 4
- else if (multip .eq. 3) then
- notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))
- lnote = 5
- else if (multip .eq. -2) then
- notexq = sq//'wh'
- else if (multip .eq. -3) then
- notexq = sq//'breve'
- lnote = 6
- else
- print*
- print*,'(Error in beamn1, send source to Dr. Don)'
- call stop1()
- end if
- if (btest(nacc(ivx,ip1),19) .or. btest(nacc(ivx,ip1),27)) then
-c notexq = notexq(1:3)//'p'
-c lnote = 4
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
- notexq = notexq(1:lnote)//noteq
- lnote = lnote+lnoten
- end if
- return
- end if
-c
-c Check if mult. decreases from 1st note to 2nd
-c
- if (ibm2(ivx,ibmcnt(ivx)).gt.ip1
- * .or. btest(islur(ivx,ip1),20)) then
-c
-c More than one note or single-note before a multiplicity-down-up "]["
-c
- if (btest(islur(ivx,ip1),20)) then
- multr = 1
- else if (.not.btest(irest(ivx,ip1+1),0)) then
- multr = iand(15,mult(ivx,ip1+1))-8
- else
- multr = iand(15,mult(ivx,ip1+2))-8
- end if
- lnote = 0
-c
-c Check if staff-jumper
-c
- if (isbjmp .and. ivbj2.gt.0) then
- ivxp = ivbj1
- else
- ivxp = ivx
- end if
- if (multr .lt. multip) then
- do 1 im = multip , multr+1 , -1
-c
-c Right-shifted 'termination'
-c
- if (isbjmp .and. ivbj2.gt.0) then
-c
-c Jump beam
-c
- call ntrbbb(im,'t',ulq(ivxp,ibmcnt(ivx)),
- * ivxp,notexq,lnote)
- else
-c
-c Same staff
-c
- call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivxp,notexq,lnote)
- end if
-1 continue
- end if
- end if
-c
-c Check for beamed, dotted 2-note tremolo
-c
- if (btest(irest(ivx,ip1),2) .and.
- * abs(nodur(ivx,ip1+1)/12.-nodur(ivx,ip1+1)/12).lt..001) then
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- gotnote = .true.
- if (lnoten .eq. 1) then
- noteq = ' '//noteq(1:1)
- lnoten = 2
- end if
- end if
-c
-c Put in the note, but check first for open-head beamed tremolo.
-c
- if (btest(irest(ivx,ip1),2) .and. nodur(ivx,ip1+1).ge.32) then
-c
-c 2-note open head tremolo
-c
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'hb'
- else
- notexq = sq//'hb'
- end if
- else
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'qb'
- else
- notexq = sq//'qb'
- end if
- end if
- lnote = lnote+3
- if (btest(irest(ivx,ip1),2) .and.
- * (nodur(ivx,ip1+1).eq.24.or.nodur(ivx,ip1+1).eq.12
- * .or.nodur(ivx,ip1+1).eq.48)) then
-c
-c 2-note trem on dotted note
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
-c
-c Check for dot
-c
- isdotm = .false.
- if (.not.vxtup(ivx)) then
- nd = nodur(ivx,ipo(jn))
- if (nd.ne.0) then
- if (2**log2(nd).ne.nd) then
- if (.not.btest(iornq(ivx,ip1),13)) then
- if (.not.btest(islur(ivx,ip1),3)) then
- notexq = notexq(1:lnote)//'p'
- else
-c
-c Double dot
-c
- notexq = notexq(1:lnote)//'pp'
- lnote = lnote+1
- end if
- else
- notexq = notexq(1:lnote)//'m'
- isdotm = .true.
- end if
- lnote = lnote+1
- end if
- end if
- else if (btest(nacc(ivx,ip1),19) .or.
- * btest(nacc(ivx,ip1),27)) then
-c
-c In an xtup with special 2:1 notation with a dot on 1st note, or normal dot
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
-c
-c Do the number; 0 if 12
-c 5/25/08 allow >12
-c
- if (.not.btest(irest(ivx,ip1),24)) then
- call istring(mod(ivx,24),numq,len)
- else
-c
-c 1st note of staff-jumping beam
-c
- call istring(mod(ivbj1,24),numq,len)
- end if
- notexq = notexq(1:lnote)//numq(1:len)
- lnote = lnote+len
- if (.not.gotnote) then
- call notefq(noteq,lnoten,nole,ncmid(iv,ip1))
- end if
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (isdotm) then
- if (lnoten .eq. 1) then
- notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- return
- end
- subroutine beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- character*40 restq
- character*79 inameq
- logical beamon,firstgulp,figbass,figchk,btest,
- * isfig,vxtup,bar1syst,addbrack,flipend,xto,drawbm
- common /comeskz2/ eskz2(nm,200)
- common /comoct/ noctup
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig,
- * lnam(nm),inameq(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
-c
-c The following is just to save the outputs from SetupB for the case of
-c xtups starting with a rest, where beamstrt is called twice.
-c
- common /comipb/ nnb,sumx,sumy,ipb(24),smed
- character*1 chax
- character*8 noteq
- character*79 notexq,tempq
- integer nornb(nm),ihornb(nm,24)
- real*4 space(80),squez(80)
- logical novshrinktop,cstuplet,usexnumt,writebrests
- common /comnvst/ novshrinktop,cstuplet
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2,ivvfig(2,74)
- character*10 figq
- common /xjbeambrests/ nbrests
- writebrests = .true.
- ibc = ibmcnt(ivx)
- ipb1 = ibm1(ivx,ibc)
- multb = iand(15,mult(ivx,ipb1))-8
- ip = ipo(jn)
- lnote = 0
- nvtrem = 0 ! Vertical adjustment beams for tremolo
-c
-c Compute slopes and note offsets from start of beam. Inside SetupB, for each
-c xtup in the beam, set eloff,mtupv (in comxtup) for printed number. Also
-c gets islope(ivx), transferred in common.
-c
- if (ixrest(ivx).eq.0 .and. .not.btest(nacc(ivx,ip),21))
- * call SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest(ivx))
-c
-c Will always come past here after entering beamstrt for 2-note tremolo, and
-c slope will have been computed, even for unbeamed. So start the indented
-c beams here. The indented tremolo bars will be added to the notexq output
-c string, under the tacet assumption that there is no horizontal shift
-c enacted by the action just before and after the call to beamstrt.
-c
- if (btest(irest(ivx,ipb1),2) .and.
- * igetbits(irest(ivx,ipb1),2,5) .gt. 0) then
- nindent = igetbits(irest(ivx,ipb1),2,5)
- tempq = sq//'roffset{.7}{'//sq//'ib'
- ltemp = 16
- if (nindent .eq. 2) then
- tempq = tempq(1:16)//'b'
- ltemp = 17
- else if (nindent .eq. 3) then
- tempq = tempq(1:16)//'bb'
- ltemp = 18
- end if
-c
-c Use beam # 0 for indented beams
-c
- tempq = tempq(1:ltemp)//ulq(ivx,ibc)//'0'
- ltemp = ltemp+2
-c
-c Get adjustment to nolev1 for main beam based on nindent
-c
- if (ulq(ivx,ibc) .eq. 'u') then
- nvtrem = nindent-1
- else
- nvtrem = 1-nindent
- end if
-c
-c Get numerical position of initiation for main beam. Will adjust height at
-c closing to account for nindent
-c
- numinit = nolev1(ivx)-ncmid(iv,ipb1)+4
-c
-c Get forced beam height tweak, apply here for indented beams
-c
- iadj = igetbits(ipl(ivx,ipb1),6,11)-30
- if (iadj .ne. -30) numinit = numinit+iadj
- if (numinit.ge.0 .and. numinit.le.9) then
- write(noteq,'(i1)') numinit
- lnoten = 1
- else
- write(noteq,'(a1,i2,a1)')'{',numinit,'}'
- lnoten = 4
- end if
- tempq = tempq(1:ltemp)//noteq(1:lnoten)
- ltemp = ltemp+lnoten
-c
-c Now do the slope.
-c 170408 Baseline is in islope(ivx). Apply slope tweak if present.
-c
- numinit = islope(ivx)
- iadj = igetbits(ipl(ivx,ipb1),6,17)-30
- if (iadj .ne. -30) numinit = numinit+iadj
- if (numinit.ge.0 .and. numinit.le.9) then
- write(noteq,'(i1,a1)') numinit,'}'
- lnoten = 2
- else
- write(noteq,'(a1,i2,a2)')'{',numinit,'}}'
- lnoten = 5
- end if
- tempq = tempq(1:ltemp)//noteq(1:lnoten)
- ltemp = ltemp+lnoten
- notexq = tempq
- lnote = ltemp
- end if
- if (btest(nacc(ivx,ip),21)) then
-c
-c This is start of later segment of single-slope beam group so use slope and
-c height from prior beam. Slope is already OK.
-c
- issb(ivx) = issb(ivx)+1
- nolev1(ivx) = lev1ssb(ivx,issb(ivx))
- end if
-c
-c Move this up to before indented beams for tremolo
-c lnote = 0
- drawbm(ivx) = .true.
- if (btest(irest(ivx,ipb1),28) .and. ixrest(ivx).ne.2) then
- vxtup(ivx) = .true.
- nxtinbm(ivx) = nxtinbm(ivx)+1
-c
-c irest(28)=>Xtup starts on this note. Set up for xtuplet.
-c Number goes on notehead side at middle note (or gap) of xtup, unless that
-c puts it in staff, then it flops to stem (or beam) side.
-c __ __
-c | | | O | |
-c O | | O
-c |___| O |__| |
-c
-c iud -1 -1 1 1 ...stem direction
-c iflop 0 1 -1 0 ...direction of flop
-c iup -1 1 -1 1 ...direction of number and bracket
-c
- iud = 1
- if (ulq(ivx,ibc) .eq. 'u') iud = -1
-c
-c Get ip#, note level of middle note (or gap) in xtup
-c
- ipmid = ipb1+ntupv(ivx,nxtinbm(ivx))/2
-c
-c 130129 If middle note is a rest, go to next note. Note last note cannot
-c be a rest
-c
-14 continue
- if (btest(irest(ivx,ipmid),0)) then
- ipmid = ipmid+1
- go to 14
- end if
- xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud,
- * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8)
- if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) xnlmid = (xnlmid+
- * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud,
- * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2
- iflop = 0
- if (abs(xnlmid-ncmid(iv,ipb1)).lt.3.) iflop = -iud
- iup = iud+2*iflop
- if (btest(irest(ivx,ipb1),14)) then
-c
-c Alter iud, iflop, iup to flip number/bracket. (Stare at above pic)
-c
- iup = -iup
- iflop = 0
- if (iud*iup .lt. 0) iflop = iup
- end if
-c
-c Determine if a beam is to be drawn.
-c Had problem w/ half-note 2-note xtups always F, so add a test
-c
- if (igetbits(irest(ivx,ipb1),2,3) .ne. 0) then
- drawbm(ivx) = .true.
- go to 6
- end if
- do 5 ipp = ibm1(ivx,ibc),ibm2(ivx,ibc)
- if (iand(15,mult(ivx,ipp))-8 .le. 0) then
- drawbm(ivx) = .false.
- go to 6
- end if
-5 continue
- drawbm(ivx) = .not.btest(islur(ivx,ibm1(ivx,ibc)),18)
-6 continue
-c
-c Are we using tuplet.tex?
-c
- usexnumt = cstuplet .and. .not.drawbm(ivx)
-c
-c Check for single note xtup 171217
-c
- if (btest(irest(ivx,ipb1),28) .and. nnb.eq.1) then
- drawbm(ivx) = .false.
- end if
-c
-c Place xtup number if needed
-c
- if (.not.btest(islur(ivx,ipb1),31) .or. multb.le.0) then
- mprint = igetbits(nacc(ivx,ip),5,22)
- if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx))
-c Stab in the dark! Note: tried setting unbeam flag islur18 but no go.
- if (nnb .eq. 1) then
- xnlmid = nolev1(ivx)
- islope(ivx) = 0
-c
-c Move up, outside number check block, so all 1-note xtups ar unbeamed
-c drawbm(ivx) = .false.
-c
- end if
- call putxtn(mprint,iflop,multb,iud,wheadpt,
- * poenom,nolev1(ivx),islope(ivx),slfac,xnlmid,islur(ivx,ipb1),
- * lnote,notexq,ncmid(iv,ipb1),nlnum,eloff(ivx,nxtinbm(ivx)),
- * iup,irest(ivx,ipb1),mult(ivx,ipb1),usexnumt)
- end if
- if (.not.drawbm(ivx)) then
-c
-c Xtuplet with no beam
-c
- if (.not.btest(islur(ivx,ipb1),31)) then
-c
-c Number printing has not been suppressed, so put in the bracket.
-c scale = stretch factor for bracket if there are asx's
-c xnsk = length of the bracket in \noteskips = (\elemskips)/(eon)
-c
- xnsk = (eskz2(ivx,ipb1+ntupv(ivx,nxtinbm(ivx))-1)
- * -eskz2(ivx,ipb1))/squez(ib)/feon(space(ib)/squez(ib))
- if (iup .eq. 1) then
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'ovbkt'
- else
- notexq = sq//'ovbkt'
- end if
- else
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'unbkt'
- else
-c
-c Introduced 12/5/98, req'd due to possible presence of in-line TeX
-c
- notexq = sq//'unbkt'
- end if
- end if
- lnote = lnote+6
- if (iline.eq.1) then
- smed = smed/(1.-fracindent)
- end if
- xslope = 1.8*smed*slfac
- islope(ivx) = nint(xslope)
- nolev1(ivx) = nlnum - nint(smed*eloff(ivx,1))
- if (islope(ivx) .eq. 0) nolev1(ivx) = nolev1(ivx)-1
- if (iup .eq. 1) nolev1(ivx) = nolev1(ivx)+4
- levbracket = nolev1(ivx)
- if (iup.eq.1 .and. cstuplet) levbracket = levbracket-1
- call notefq(noteq,lnoten,levbracket,ncmid(iv,ipb1))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
- lnote = lnote+lnoten+1
- if (xnsk .lt. 0.995) then
- write(notexq(lnote+1:lnote+4),'(i1,f3.2)')0,xnsk
- lnote = lnote+4
- else if (xnsk .lt. 9.995) then
- write(notexq(lnote+1:lnote+4),'(f4.2)')xnsk
- lnote = lnote+4
- else
- write(notexq(lnote+1:lnote+5),'(f5.2)')xnsk
- lnote = lnote+5
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- if (btest(mult(ivx,ipb1),4)) then
-c
-c Tweak slope of bracket
-c
- islope(ivx) = islope(ivx)+igetbits(mult(ivx,ipb1),5,5)-16
- end if
- if (islope(ivx).lt.0 .or. islope(ivx).ge.10) then
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (islope(ivx) .lt. -9) then
- write(notexq(lnote+1:lnote+3),'(i3)')islope(ivx)
- lnote = lnote+3
- else
- write(notexq(lnote+1:lnote+2),'(i2)')islope(ivx)
- lnote = lnote+2
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- else
- write(notexq(lnote+1:lnote+1),'(i1)')islope(ivx)
- lnote = lnote+1
- end if
-c
-c Done with bracket
-c
- end if
- if (ixrest(ivx) .eq. 1) then
-c
-c Put in the rest. Possible problem: Rest is a spacing char, but between
-c beamstrt and beamn1 some non-spacing chars. are inserted.
-c
-c 130126 Deal with vertical shifts of rest starting xtuplet
-c
- lrest = 3
- if (btest(islur(ivx,ip),29)) then
- restq = sq//'sk'
-c if (multb .eq. 0) then
- else if (multb .eq. 0) then
- restq = sq//'qp'
- else if (.not.drawbm(ivx).and.multb.eq.1) then
- restq = sq//'ds'
- else if (.not.drawbm(ivx).and.multb.eq.2) then
- restq = sq//'qs'
- else if (.not.drawbm(ivx).and.multb.eq.3) then
- restq = sq//'hs'
- else
- restq = sq//'hpause'
- lrest = 7
- end if
- if (btest(nacc(ivx,ipb1),18) .and.
- * btest(nacc(ivx,ipb1),19)) then
-c
-c VERY special case of rest at start of F-tuplet, needs dot
-c
- restq = sq//'pt4'//restq(1:lrest)
- lrest = lrest+4
- end if
-
- nole = mod(nolev(ivx,ip)+20,100)-20
-c if (nole .eq. 0) then
- if (nole.eq.0 .or. btest(islur(ivx,ip),29)) then
-c
-c Rest blank or is not raised
-c
- notexq = notexq(1:lnote)//restq
- lnote = lnote+lrest
- else
- if (abs(nole) .lt. 10) then
- tempq = chax(48+abs(nole))
- ltemp = 1
- else
- write(tempq(1:2),'(i2)')abs(nole)
- ltemp = 2
- end if
- if (nole .gt. 0) then
- tempq = sq//'raise'//tempq(1:ltemp)//sq//'internote'
- else
- tempq = sq//'lower'//tempq(1:ltemp)//sq//'internote'
- end if
- ltemp = 16+ltemp
- notexq = notexq(1:lnote)//tempq(1:ltemp)//restq(1:lrest)
- lnote = lnote+ltemp+lrest
- end if
-c
-c No need to come back through this subroutine (as would if rest starts bar
-c & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing.
-c
- ixrest(ivx) = 0
- end if
- return
- end if
-c
-c End if block for non-beamed xtup start...note we returned
-c
- if (ixrest(ivx) .eq. 1) then
-c
-c Insert rest at start of beamed xtup. See above note for possible problem.
-c But first check if blank rest and if in forced beam (assuming xtuplet),
-c and if so, count rest from beginning, add \sk's AFTER starting beam '\ib*'
-c
- if (btest(islur(ivx,ip),29) .and. btest(ipl(ivx,ip),30)) then
- nbrests = nbrests+1
- writebrests = .false.
- else
- nodur(ivx,ipb1) = 2**(4-multb)
- call notex(tempq,ltemp)
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//tempq(1:ltemp)
- else
- notexq = tempq(1:ltemp)
- end if
- lnote = lnote+ltemp
- end if
-c
-c Re-zero just in case!
-c
- nodur(ivx,ipb1) = 0
- ibm1(ivx,ibc) = ibm1(ivx,ibc)+1
-c
-c See if next note is a non-rest
-c
- if (.not.btest(irest(ivx,ipb1+1),0)) then
- ixrest(ivx) = 2
- else
-c
-c Suppress reprinting xtup number next time through beamstrt
-c
- islur(ivx,ipb1+1) = ibset(islur(ivx,ipb1+1),31)
-c
-c Set new xtup start flag
-c
- irest(ivx,ipb1+1) = ibset(irest(ivx,ipb1+1),28)
- end if
- return
- end if
- end if
-c
-c Just ended if block for xtups
-c
- if (vxtup(ivx) .and. ipb1.eq.ibm2(ivx,ibc)) then
-c
-c Move actual note writing to beamend
-c
- ixrest(ivx) = 4
- return
- end if
- if (issb(ivx) .eq. 0) then
-c
-c 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed
-c
- iadj = igetbits(ipl(ivx,ipb1),6,11)-30
- if (iadj .ne. -30) then
- nolev1(ivx) = nolev1(ivx)+iadj
- do 2 isssb = 1 , nssb(ivx)
- lev1ssb(ivx,isssb) = lev1ssb(ivx,isssb)+iadj
-2 continue
- end if
- iadj = igetbits(ipl(ivx,ipb1),6,17)-30
- if (iadj .ne. -30) then
- islope(ivx) = islope(ivx)+iadj
- if (abs(islope(ivx)) .gt. 9) islope(ivx) = sign(9,islope(ivx))
- if (nssb(ivx) .gt. 0) then
-c
-c Cycle thru non-rest notes in SSBG, looking for bmstrts.
-c
- isssb = 0
- do 4 inb = 2, nnb
- if (btest(nacc(ivx,ipb(inb)),21)) then
-c
-c Beam segment start. New start level
- isssb = isssb+1
- lev1ssb(ivx,isssb) =
- * lev1ssb(ivx,isssb)+islope(ivx)*xelsk(inb)/slfac
- end if
-4 continue
- end if
- end if
- end if
- iadj = igetbits(islur(ivx,ipb1),2,27)
- addbrack = .false.
- if (btest(ipl(ivx,ipb1),30)) then
-c
-c Check for altered starting polarity. Only in forced beams. Nominal start
-c level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.).
-c
- if (ulq(ivx,ibc).eq.'u' .and.
- * nolev1(ivx)+6.lt.nolev(ivx,ipb1)) then
- if (lnote .eq. 0) then
- notexq = sq//'loff{'
- else
- notexq = notexq(1:lnote)//sq//'loff{'
- end if
- lnote = lnote+6
- addbrack = .true.
- else if (ulq(ivx,ibc).eq.'l' .and.
- * nolev1(ivx)-6.gt.nolev(ivx,ipb1)) then
- if (lnote .eq. 0) then
- notexq = sq//'roff{'
- else
- notexq = notexq(1:lnote)//sq//'roff{'
- end if
- lnote = lnote+6
- addbrack = .true.
- end if
-c
-c Check end level for possible flipping in forced beam. Have to do it
-c here since with multiple voices, xelsk will not be preserved.
-c
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
- bmlev = nolev1(ivx)+6+islope(ivx)*xelsk(nnb)/slfac
- flipend(ivx) = bmlev.lt.nolev(ivx,ibm2(ivx,ibc))
- else if (ulq(ivx,ibmcnt(ivx)) .eq. 'l') then
- bmlev = nolev1(ivx)-6+islope(ivx)*xelsk(nnb)/slfac
- flipend(ivx) = bmlev.gt.nolev(ivx,ibm2(ivx,ibc))
- end if
- end if
- multbb = multb+iadj
-c
-c Tremolo starting?
-c
- if (btest(irest(ivx,ipb1),2)) multbb =
- * igetbits(irest(ivx,ipb1),2,3)
- call ntrbbb(multbb,'i',ulq(ivx,ibc),ivx,notexq,lnote)
-c
-c Put in name of start level and slope, after correcting nolev1 if xtup
-c started with a rest.
-c
- if (ixrest(ivx).eq.2) nolev1(ivx) =
- * nint(nolev1(ivx)+xelsk(1)*islope(ivx)/slfac)
-c
-c Add adjustment nvtrem to main beam to account for tremolo indented beams
-c
- call notefq(noteq,lnoten,nolev1(ivx)+nvtrem,ncmid(iv,ipb1))
- if (islope(ivx) .lt. 0) then
- notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
- lnote = lnote+4+lnoten
- write(notexq(lnote-2:lnote),'(i2,a1)')islope(ivx),'}'
- else
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+1+lnoten
- write(notexq(lnote:lnote),'(i1)')islope(ivx)
- end if
-c
-c Check for beam-thk fine-tuning
-c
- if (iadj .gt. 0) then
- do 1 imp = multb+iadj , multb+1 , -1
- call ntrbbb(imp,'t',ulq(ivx,ibc),ivx,notexq,lnote)
-1 continue
- end if
-c
-c If we shifted, must close with right bracket
-c
- if (addbrack) then
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
-c
-c Add in \sk's for very special case of staff-crossing xtup chords
-c Assumes we are in lower (first) voice of up-to-both beamed xtup
-c that starts with blank rests (notes in upper voice here).
-c
- if (nbrests.gt.0 .and. writebrests) then
- do 7 isk = 1 , nbrests
- notexq = notexq(1:lnote)//chax(92)//'sk'
- lnote = lnote+3
-7 continue
- nbrests = 0
- end if
-c
-c Get 'floor' zmin for figures
-c Note: Will not come thru here on 1st note of unbeamed xtup, so figure height
-c won't be adjusted. If anyone ever needs that, need to duplicate this
-c functionality up above, before exiting.
-c
- if (figbass .and. (ivx.eq.1 .or. ivx.eq.ivxfig2)) then
- if (ivx .eq. 1) then
- ivf = 1
- else
- ivf = ivxfig2
- end if
- zmult = 1.2*(multb-1)
- ymin = 100.
- do 3 inb = 1, nnb
- if (isfig(ivf,ipb(inb))) then
- if (ulq(iv,ibc) .eq. 'u') then
- ybot = nolev(iv,ipb(inb))
- else
- ybot = islope(ivx)/slfac*xelsk(inb)+nolev1(ivx)
- * -stemlen-zmult
- end if
- ymin = min(ymin,ybot)
- end if
-3 continue
- maxdrop = ncmid(iv,ipb1)-4-ymin+5.01
- ifigdr(ivf,iline) = max(ifigdr(ivf,iline),maxdrop)
- end if
-c
-c Compute ornament levels if needed
-c
- NomOrnLev = ncmid(iv,ipb1)+5
- iorn = 0
- do 8 inb = 1 , nnb
- ip = ipb(inb)
- if (.not.btest(iornq(ivx,ip),23)) go to 8
- if (btest(irest(ivx,ip),26) .and. ulq(ivx,ibc).eq.'l') then
-c
-c letter-dynamic or hairpin ending under down-beamed
-c
- iorn = iorn+1
- ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1
- * -1.2*(multb-1)
- ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10)
- else if (.not.btest(ipl(ivx,ip),10)) then
-c
-c Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F
-c 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD
-c
-c Non-chord. There IS an ornament. Need ihornb only if upbeam, and if
-c ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.)
-c
- if (ulq(ivx,ibc).eq.'u' .and.
- * iand(iornq(ivx,ipb(inb)),4163566).gt.0) then
- iorn = iorn+1
- iornq(ivx,ip) = ibset(iornq(ivx,ip),22)
- ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1
- * +1.2*(multb-1)
- ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev)
- end if
- else
-c
-c In a chord. Orn may be on main note or non-main or both. Set ihornb if
-c upbeam and highest note has orn, or down beam and lowest. Find 1st chord note
-c
- do 10 icrd1 = 1 , ncrd
- if (iand(255,icrdat(icrd1)) .eq. ip .and.
- * iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 11
-10 continue
-11 continue
-c
-c Find outermost note, min or max depending on beam direction ulq. xto is true
-c if there's an ornament on that note. Expand orn list to include ._, since if
-c on extreme chord note in beam, will move.
-c So ornaments are all except 0,4,13 (,g,)
-c
- levx = nolev(ivx,ip)
- xto = iand(iornq(ivx,ipb(inb)),4186094).gt.0
- icrdx = 0
- do 12 icrd = icrd1 , ncrd
- if (iand(255,icrdat(icrd)) .ne. ip .or.
- * iand(15,ishft(icrdat(icrd),-8)) .ne. ivx) go to 13
- levc = iand(127,ishft(icrdat(icrd),-12))
- if ((ulq(ivx,ibc).eq.'u'.and.levc.gt.levx) .or.
- * (ulq(ivx,ibc).eq.'l'.and.levc.lt.levx)) then
- levx = levc
- icrdx = icrd
- xto = iand(icrdorn(icrd),4186094).gt.0
- end if
-12 continue
-13 continue
-c
-c If there's orn on extreme note, do stuff
-c
- if (xto) then
- iorn = iorn+1
- if (ulq(ivx,ibc) .eq. 'u') then
- ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1
- * +1.2*(multb-1)
- ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev)
- else
- ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1
- * -1.2*(multb-1)
- ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10)
- end if
- if (icrdx .eq. 0) then
-c
-c Affected ornament is on main note
-c
- iornq(ivx,ip) = ibset(iornq(ivx,ip),22)
- else
- icrdorn(icrdx) = ibset(icrdorn(icrdx),22)
- end if
- end if
- end if
-8 continue
-c
-c Henceforth nornb will be a counter.
-c
- if (iorn .gt. 0) nornb(ivx)=1
- if (ixrest(ivx) .eq. 2) ixrest(ivx) = 0
- return
- end
- block data
- parameter (nm=24)
- common /comtol/ tol
- common /comtrans/ cheadq
- common /compage/ widthpt,ptheight,hoffpt,voffpt,
- * nsyst,nflb,ibarflb(0:40),
- * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
- * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30),
- * nistaff(0:40)
- common /cblock/
- * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
- * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh
- common /cominbot/ inbothd
- logical usefig
- common /comstart/ facmtr
- character*60 cheadq
- character*120 instrq,titleq,compoq
- logical headlog
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /combmh/ bmhgt,clefend
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- logical kbdrests
- common /comkbdrests/ levbotr(8),levtopr(8),kbdrests
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /comsize/ isize(nm)
-c
- data tol /.001/
- data cheadq
- * /' '/
- data gslfac /9./
- data instrq,titleq,compoq,headlog /3*' ',.false./
-c
-c meter space (pts) = xb4mbr = musicsize*facmtr
-c
- data facmtr /0.55/
- data grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,clefend,bmhgt
- * / 1.3333,.4 , .7 , .3 , 0.2 , 2.0 , 1.0 ,
- * .7,.7 ,.9 ,.5 ,2.3 ,1.1 /
- data rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,arpfac
- * / 1.32 , 2.25 , 0.47 , 0.83 , 0.17 , 0.5 , 1.7 /
- data rtshfac / 1.0 /
- data isize /nm*0/
-c
-c From other
-c
- data ptheight,widthpt,hoffpt,voffpt,
- * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
- * xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh
- * / 740. , 524. , 0., 0.,
- * .50 , .25 , 0.4 , 0.4 , 0.2 , 12. ,21. , 12.,
- * 4 , 1.6 ,5.,5.7,1.071,2.714,16 ,16 /
- data fracsys /30*0./
- data ivowg,hoh1,hoh2,hoh2h1 /0,0,0,0,0,1,1,1,1,1,1,1,
-c * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6,
- * 2.2,1.7,1.2,0.7,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6,
- * -2.7,-2.2,-1.7,-1.2,-2.3,-2.1,-1.0,-1.7,-2.1,-1.6,-1.9,-2.3,
- * -0.3,0.3 /
- data kbdrests /.false./,
- * levtopr /9,7,5,5,7,5,6,6/, levbotr /0,0,0,2,1,4,5,4/
- data EarlyTransOn, LaterInstTrans /2*.false./
- data iInstTrans /nm*0/
- data iTransAmt /nm*0/
- end
- subroutine catspace(space,squez,nnsk)
- parameter (nkb=3999,maxblks=9600)
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
-c * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- * ibaroff,udsp(nkb),wheadpt,sqzb(maxblks)
- common /comtol/ tol
-c logical gotclef
- do 16 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1
- if (abs(space-durb(iptr)) .lt. tol) then
- if (abs(squez-sqzb(iptr)) .lt. tol) then
-c
-c Increment pre-existing entry
-c
- nnpd(iptr) = nnpd(iptr)+nnsk
- return
- end if
- end if
-16 continue
-c
-c Didn't find current duration & squez, so add a new entry.
-c No particular reason to keep in order, so add at the end.
-c
- nnpd(nptr(ibarcnt+1)) = nnsk
- durb(nptr(ibarcnt+1)) = space
- sqzb(nptr(ibarcnt+1)) = squez
- nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
- return
- end
- character*1 function chax(n)
-c
-c The only reason for this seemingly do-nothing function is to get around an
-c apparent bug in the Visual Fortran Standard Edition 5.0.A compiler!
-c
- chax = char(n)
- return
- end
- subroutine checkdyn(lineq,iccount,ibar)
- character*128 lineq
- character*1 durq,chax
- character*4 dynsymq
- logical txtdyn
- txtdyn = .false.
-c
-c On entry, iccount is on "D"
-c
- if (lineq(iccount+1:iccount+1) .eq. '"') then
-c
-c Dynamic text
-c
-
- istart = iccount+2 ! 1 past 1st quote
-3 continue
- iend = index(lineq(istart:128),'"')
- if (lineq(istart+iend-2:istart+iend-2) .eq. '\') then
- istart = iccount+iend+2
- go to 3
- end if
- if (iend .eq. 0) then
- call errmsg(lineq,iccount+1,ibar,
- * 'Dynamic text must be terminated with double quote!')
- call stop1()
- end if
-c
-c Set iccount to character after 2nd ", and set ipm
-c
-c iccount = iccount+iend+2
- iccount = istart+iend
- ipm = index('- +',lineq(iccount:iccount))
- if (ipm .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected "-", "+", or blank here!')
- call stop1()
- end if
- else
-c
-c Expect ordinary dynamic
-c
- do 1 iend = iccount+2 , 128
- ipm = index('- +',lineq(iend:iend))
- if (ipm .gt. 0) go to 2
-1 continue
-2 continue
- if (iend-iccount.gt.5 .or. iend-iccount.lt.2) then
- call errmsg(lineq,iend-1,ibar,
- * 'Wrong length for dynamic mark!')
- call stop1()
- end if
- read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')')
- * dynsymq
- idno = (index(
- * 'ppppppp pp p mp mf f fp sfz ff fff ffff< > ',
- * dynsymq)+3)/4
- if (idno .eq. 0) then
- call errmsg(lineq,iccount+1,ibar,'Illegal dynamic mark!')
- call stop1()
- end if
- iccount = iend
- end if
- if (ipm .ne. 2) then
-c
-c There is a vertical shift, have "+" or "-"
-c
- iccount = iccount+1
- if (index('0123456789',lineq(iccount:iccount)) .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected integer here for vertical offset!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(fnum)
- if (idno .gt. 63) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Vertical offset for dynamic mark must be (-63,63)!')
- call stop1()
- end if
- ipm = index('- +',durq)
- if (ipm .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected "+", "-", or blank here!')
- call stop1()
- end if
- if (ipm .ne. 2) then
-c
-c There is a horizontal shift
-c
- iccount = iccount+1
- if (index('.0123456789',lineq(iccount:iccount)) .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected number here for horizontal offset!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(10*fnum)
- if (idno .gt. 255) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Horizontal offset for dynamic mark must be (-25.5,25.5)!')
- call stop1()
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibar,
- * 'There should be a blank here!')
- call stop1()
- end if
- end if
-c
-c iccount should be on the blank at the end of the entire symbol
-c
- end if
- return
- end
- subroutine chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp)
-c subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp,
-c * icashft)
- logical found1,iscacc,isarp,btest
- integer icrdat(193)
- found1 = .false.
-c
-c icashft will be max left shift of accid's in chord notes.
-c Used only for spacing checks.
-c Will include left shift of chord note itself.
-c Rezero after use.
-c
- do 18 icrd = 1 , ncrd
-c
-c This if block cycles thru all chord notes on ivx,ip; then returns.
-c
- if (iand(255,icrdat(icrd)) .eq. ip .and.
- * iand(15,ishft(icrdat(icrd),-8)) .eq. ivx) then
- found1 = .true.
- iscacc = iscacc .or.
- * (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27))
-c
-c Accid on this chord note, and it's not midi-only.
-c
-c irshft = igetbits(icrdot(icrd),7,20)
-cc
-cc Include increment for notehead shift
-cc
-c if (btest(icrdat(icrd),23)) then
-c if (irshft .eq. 0) then
-c irshft = 44
-c else
-c irshft=irshft-20
-c end if
-c end if
-c if (irshft .ne. 0) then
-cc
-cc Accid on chord note is shifted. Include only left shift, in 20ths.
-cc
-c if (irshft .lt. 64) icashft = max(icashft,64-irshft)
-c end if
-c end if
- isarp = isarp .or. btest(icrdat(icrd),25)
- else if (found1) then
- return
- end if
-18 continue
- return
- end
- subroutine chkimidi(icm)
- parameter (nm=24,mv=24576)
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- if (imidi(icm) .ge. mv) then
- print*
- print*,'Midi file is too long! It will be corrupted or worse'
- write(*,'(a6,2x,4i8)')
- * 'imidi:',imidi(0),imidi(1),imidi(2),imidi(3)
- end if
- return
- end
- subroutine chkkbdrests(ip,iv,ivx,nn,islur,irest,nolev,ivmx,
-c * nib,nv,ibar,tnow,tol,nodur,mode,levtopr,levbotr,mult)
- * nib,nv,ibar,tnow,tol,nodur,mode,levtopr,levbotr,mult,ipl)
- parameter (nm=24)
- integer*4 nn(nm),islur(nm,200),irest(nm,200),
- * nolev(nm,200),nib(nm,15),nodur(nm,200),levbotr(8),levtopr(8),
- * ivmx(nm,2),mult(nm,200),ipl(nm,200)
-c
-c On 130127 put this code, formerly in make2bar right before calling notex for
-c a single note/rest, into this subroutine, so the same logic could also be
-c with the calls to beamstrt/mid/end to adjust height of rests in xtups if the
-c keyboard rest option is selected
-c
-c mode=1 if called as before, 2 if for an xtup. Only affects check for
-c quarter rests, which will fix later.
-c
-c Get reference level: next following note if no intervening blank rests,
-c otherwise next prior note. Relative to bottom line.
-c
-c if (ip.ne.nn(ivx).and..not.btest(iornq(ivx,ip),30)) then
- if (ip.ne.nn(ivx).and..not.btest(ipl(ivx,ip),1)) then
-c
-c Not the last note and not "look-left" for level
-c
- do 8 kkp = ip+1 , nn(ivx)
- if (btest(islur(ivx,kkp),29)) go to 4
- if (.not.btest(irest(ivx,kkp),0)) then
- levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line
- go to 9
- end if
-8 continue
- end if
-4 continue
-c
-c If here, there were no following notes or came to a blank rest, or
-c "look-left" option set. So look before
-c
-c if (ip .eq. 1) go to 2 ! Get out if this is the first note.
- if (ip .eq. 1) return ! Get out if this is the first note.
- do 3 kkp = ip-1, 1, -1
- if (.not.btest(irest(ivx,kkp),0)) then
- levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line
- go to 9
- end if
-3 continue
-c go to 2 ! Pretty odd, should never be here, but get out if so.
- return ! Pretty odd, should never be here, but get out if so.
-9 continue
-c
-c Find note in other voice at same time
-c
- iupdown = sign(1,ivx-nv-1)
- ivother = ivmx(iv,(3-iupdown)/2)
- tother = 0.
- do 5 kkp = 1 , nib(ivother,ibar)
- if (abs(tother-tnow) .lt. tol) go to 6
- tother = tother+nodur(ivother,kkp)
-5 continue
-c
-c If here, then no note starts in other voice at same time, so set default
-c
- levother = -iupdown*50
- go to 7
-6 continue
-c
-c If here, have just identified a simultaneous note or rest in other voice
-c
- if (.not.btest(irest(ivother,kkp),0)) then ! Not a rest, use it
- levother = nolev(ivother,kkp)-ncmid(iv,ip)+4
- else
- if (nodur(ivother,kkp) .eq. nodur(ivx,ip)) then
-c
-c Rest in other voice has same duration, get out (so defualt spacing is used)
-c
-c go to 2
- return
- end if
- levother = -iupdown*50
- end if
-7 continue
- if (mode.eq.1) then
- indxr = log2(nodur(ivx,ip))+1
- else
-c nodu = 2**(4-(iand(mult(ivx,ip),15)-8))
- indxr = 4-(iand(mult(ivx,ip),15)-8)+1
- end if
- if (iupdown .lt. 0) then
- levtop = levtopr(indxr)
- iraise1 = levother-levtop-3 ! Based on other note
- iraise2 = levnext-levtop ! Based on following note
- if (indxr.eq.5 .and. levnext.lt.1) iraise2=iraise2+2
- iraise = min(iraise1,iraise2)
- if (mod(iraise+50,2).eq.1 .and.
- * iraise+levtop.gt.-1) iraise = iraise-1
- else
- levbot = levbotr(indxr)
- iraise1 = levother-levbot+3
- iraise2 = levnext-levbot
- if (indxr.eq.5 .and. levnext.gt.8) iraise2=iraise2-1
- iraise = max(iraise1,iraise2)
- if (mod(iraise+50,2).eq.1 .and.
- * iraise+levbot.le.9) iraise = iraise-1
- end if
- nolev(ivx,ip) = 100+iraise
- return
- end
- subroutine chklit(lineq,iccount,literr)
- character*128 lineq
- character*1 charq,chax
- literr = 0
- itype = 1
-17 call g1etchar(lineq,iccount,charq)
- if (charq .eq. chax(92)) then
- itype = itype+1
- if (itype .gt. 3) then
- literr = 1
- return
- end if
- go to 17
- end if
- lenlit = itype
-18 call g1etchar(lineq,iccount,charq)
- if (charq.eq.chax(92)) then
- call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') then
-c
-c Starting a new tex command withing the string
-c
- lenlit = lenlit+2
- if (lenlit .gt. 128) then
- literr = 2
- return
- end if
- go to 18
- end if
- else
- lenlit = lenlit+1
- if (lenlit .gt. 128) then
- literr = 2
- return
- end if
- go to 18
- end if
- return
- end
- subroutine chkpm4ac(lineq,iccount,nacc,moved)
-c
-c Called after getting +/-/</> in a note (not rest). iccount is on the +-<>.
-c Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits
-c 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed
-c numbers. If moved=.true., iccount on exit is on end of last number.
-c If moved=.false., iccount still on +/-
-c
- logical moved,ishorz
- character*128 lineq
- character*1 durq
- if (index('sfnA',lineq(iccount-1:iccount-1)).gt.0 .and.
- * index('0123456789.',lineq(iccount+1:iccount+1)).gt.0) then
-c
-c Prior char was accid & next is #; this may be start of accidental shift.
-c Must test for "." above in case we get "<" or ">"
-c
- ipm = index('- +< >',lineq(iccount:iccount))-2
- if (lineq(iccount+1:iccount+1).eq.'.' .and.
- * index('0123456789',lineq(iccount+2:iccount+2)).eq.0) then
-c
-c Rare case of [accid][+/-].[letter]. Bail out
-c
- moved = .false.
- return
- end if
- ishorz = ipm .gt. 1
-c
-c Save iccount in case it's not accid shift and we have to reset.
-c
- icsav = iccount
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (ishorz .or. index('+-',durq).gt.0) then
-c
-c This has to be accidental shift. Set vert. shift.
-c
- if (.not.ishorz) then
-c
-c +/- syntax, both shifts set, vertical first
-c
- call setbits(nacc,6,4,int(ipm*fnum+32.5))
- ipm = index('- +',durq)-2
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- else
-c
-c </> syntax, only horiz set
-c
- ipm = ipm-3
- end if
-c
-c Set horiz. shift
-c
- call setbits(nacc,7,10,nint(20*(ipm*fnum+5.35)))
- iccount = iccount-1
- moved = .true.
- else
-c
-c False alarm. Reset everything and flow onward
-c
- moved = .false.
- iccount = icsav
- end if
- else
-c
-c Either prior char was not 'sfn' or next was not digit, so take no action
-c
- moved = .false.
- end if
- return
- end
- subroutine clefsym(isl,notexq,lnote,nclef)
-c
-c Returns string calling Don's TeX macro \pmxclef, for drawing small clefs.
-c
- character*(*) notexq
- character*1 chax
- nclef = iand(ishft(isl,-12),7)
- if (nclef .eq. 0) then
-c
-c treble
-c
- nlev = 2
- else if (nclef .gt. 6) then
-c
-c French violin
-c
- nlev = 0
- else if (nclef .lt. 5) then
-c
-c C-clef
-c
- nlev = 2*nclef-2
- else
-c
-c F-clef
-c
- nlev = 2*nclef-6
- end if
- notexq = chax(92)//'pmxclef'//chax(48+min(nclef,7))
- * //chax(48+nlev)
- lnote = 10
- return
- end
- subroutine crdacc(nacc,naccid,micrd,nolevm,rmsshift,lasttime,
- * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
-c
-c nacc = accidental bitmap for main note
-c naccid = # of accid's in chord
-c micrd = array with icrd #'s for notes w/ acc's, 0=>main note
-c nolevm = level of main note
-c segrb(1|2,.) x|y-coord of right-bdry segment
-c ksegrb(.) internal use; tells what defined this segment
-c -2: Left-shifted notehead
-c -1: Original right boundary
-c 0: Main note accidental
-c icrd: Chord-note accidental
-c isetshft(i),i=1,naccid: what set shift for this accid, same codes
-c icrdot0 = top-down level-rank of main note among accid-notes
-c icrdot(icrd)(27-29) = level rank of chord-note among accid-notes
-c twooftwo will be true 2nd time thru; signal to store shifts w/ notes
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- real*4 segar(5,2,6),segal(5,2,6),segrb(2,50),segrb0(2,50)
- integer*4 nsegar(5),nsegal(5),micrd(10),iacctbl(6),ksegrb(50),
- * isetshft(10),ksegrb0(50)
- logical lasttime,mainnote,twooftwo
- data nsegar / 3,4,3,3,2 /, nsegal / 2,4,3,3,2 /
- data segar /
-c
-c Fancy sharp boundary. fl,sh,na,dfl,dsh
-c
- * -0.05,-0.38,-0.34,-.05, -.15,-1.4,-2.9,-3.0, -1.4, -1.2,
-c * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. ,
-c meas value for y, natural is 1.6
- * -0.75,-0.20,-0.80,-.75, 0. , .96,-1.04,1.48, .96, 1.2,
- * 0.00,-0.38, 0.00, 0. , 0. ,3.15, 1.64,3.0, 3.15, 0. ,
- * 0. , 0.00, 0. , 0. , 0. , 0. , 2.90, 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. /
- data segal /
-c * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. ,
-cc (meas. value is 3.08) ^^^^
-cc Raise top of flat so it interferes with bottom of sharp
- * -1.00,-1.02,-0.60,-1.65, -1.2,-1.4,-2.9, -3.0, -1.4, -1.2,
- * 0.00,-1.20,-1.04, 0. , 0. ,3.15,-1.64,-1.48,3.15, 1.2,
- * 0. ,-1.02, 0.00, 0. , 0. , 0. , 1.04, 3.0, 0. , 0. ,
- * 0. , 0.00, 0. , 0. , 0. , 0. , 2.9 , 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. /
-c
-c iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6)
-c
- data iacctbl / 1 , 2 , 3 , 0 , 4 , 5 /
-c
-c Set up barrier segrb(iseg,ipoint) to define coords of corner points
-c on stem+notes
-c
- do 11 iseg = 1 , nsegrb0
- segrb(1,iseg) = segrb0(1,iseg)
- segrb(2,iseg) = segrb0(2,iseg)
- ksegrb(iseg) = ksegrb0(iseg)
-11 continue
- nsegrb = nsegrb0
- rmsshift = 0.
- shiftmin = 1000.
- do 1 iwa = 1 , naccid
-c
-c Initialize shift for this note
-c
- shift = 0.
- mainnote = micrd(iwa).eq.0
- isetshft(iwa) = -1
-c
-c Get note level and accidental type
-c
- if (mainnote) then
- nolev = nolevm
- iacctype = iacctbl(igetbits(nacc,3,0))
- else
- nolev = igetbits(icrdat(micrd(iwa)),7,12)
- iacctype = iacctbl(igetbits(icrdat(micrd(iwa)),3,20))
- end if
-c
-c Cycle thru segments on right edge of this accidental
-c
- do 2 isega = 1 , nsegar(iacctype)-1
- ybotaseg = nolev+segar(iacctype,2,isega)
- ytopaseg = nolev+segar(iacctype,2,isega+1)
-c
-c Cycle thru segments of right-hand barrier
-c
- do 3 isegrb = 1 , nsegrb-1
-c
-c Must find all barrier segments that start below ytopseg & end above ybotseg
-c
- if (segrb(2,isegrb) .lt. ytopaseg) then
-c
-c Barrier seg starts below top of accid
-c Check if barrier seg ends above bottom of accid
-c
- if (segrb(2,isegrb+1) .gt. ybotaseg) then
- if (shift .gt.
- * segrb(1,isegrb)-segar(iacctype,1,isega)) then
- shift = segrb(1,isegrb)-segar(iacctype,1,isega)
-c
-c Record the cause of the shift
-c
- isetshft(iwa) = ksegrb(isegrb)
- end if
- end if
-c
-c Does barrier segment end above top of accid seg?
-c
- if (segrb(2,isegrb+1) .gt. ytopaseg) go to 4
- end if
-3 continue
-4 continue
-2 continue
- if (.not.btest(nacc,28) .and. abs(shift).gt.0.0001
- * .and. .not.lasttime) then
-c if (nolev .eq. levmaxacc) then
- if (nolev.eq.levmaxacc .and. isetshft(iwa).eq.-1) then
- rmsshift = 1000.
- return
- end if
-c
-c Does the following properly account for left-shifted noteheads?
-c
-c Top-down rank of this note we just shifted
-c
- if (mainnote) then
- irank = icrdot0
- else
- irank = igetbits(icrdot(micrd(iwa)),3,27)
- end if
-c
-c Compare level-rank of this note vs. that of note that caused the shift.
-c This has effect of checking for basic interferences from top down.
-c
-c ksegrb(.) internal use; tells what defined this segment
-c -2: Left-shifted notehead
-c -1: Original right boundary
-c 0: Main note accidental
-c icrd: Chord-note accidental
-c isetshft(i),i=1,naccid: what set shift for this accid, same codes
-c
- if (isetshft(iwa) .lt. 0) then
- iranksetter = 0
- else if (isetshft(iwa) .eq. 0) then
- iranksetter = icrdot0
- else
- iranksetter = igetbits(icrdot(isetshft(iwa)),3,27)
- end if
- if (iranksetter.ne.0 .and. irank.ne.iranksetter+1) then
- rmsshift = 1000.
- return
- end if
- end if
- rmsshift = rmsshift+shift**2
- if (lasttime .and. abs(shift).gt..0001) then
- if (mainnote) then
- if (.not.btest(nacc,29)) go to 10
- else
- if (.not.btest(icrdat(micrd(iwa)),29)) go to 10
- end if
-c
-c If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there
-c was a manual shift but auto-shift was zero, will not come thru here, but shift value
-c will be left intact.
-c
- if (mainnote) then
- shift = shift+.05*(igetbits(nacc,7,10)-107)
- else
- shift = shift+.05*(igetbits(icrdot(micrd(iwa)),7,20)-107)
- end if
-10 continue
- if (twooftwo) then
-c
-c Record the shift for this accidental
-c
- if (shift .lt. -5.35) then
- call printl(' ')
- call printl('WARNING: auto-generated accidental '//
- * 'shift too big for PMX, ignoring')
- else
- ishift = nint(20*(shift+5.35))
- if (mainnote) then
- call setbits(nacc,7,10,ishift)
- else
- call setbits(icrdot(micrd(iwa)),7,20,ishift)
- end if
- end if
- else
-c
-c This is the earlier call to precrd, so need minimum shift
-c
- shiftmin = min(shiftmin,shift)
- end if
- end if
-c
-c Bail out if this is the last accidental to check
-c
- if (iwa .eq. naccid) go to 1
-c
-c Add this accidental to the right barrier! Count down from highest barrier segment,
-c find 1st one starting below top of accid, and first one starting below bot.
-c
- do 5 ibelowtop = nsegrb , 1 , -1
- if (segrb(2,ibelowtop) .lt.
- * nolev+segal(iacctype,2,nsegal(iacctype))) then
- do 9 ibelowbot = ibelowtop , 1 , -1
- if (segrb(2,ibelowbot) .lt.
- * nolev+segal(iacctype,2,1)) go to 6
-9 continue
- print*,'Oops2!'
- call stop1()
- end if
-5 continue
- print*,'Ugh0! in crdaccs'
- call stop1()
-6 continue
- netgain = nsegal(iacctype)-ibelowtop+ibelowbot
-c
-c Shift high segments up
-c
- if (netgain .ge. 0) then
- do 7 isegrb = nsegrb , ibelowtop+1 , -1
- segrb(1,isegrb+netgain) = segrb(1,isegrb)
- segrb(2,isegrb+netgain) = segrb(2,isegrb)
- ksegrb(isegrb+netgain) = ksegrb(isegrb)
-7 continue
-c
-c Set up 1st segment above accid
-c
- segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop)
- segrb(2,ibelowtop+netgain) =
- * nolev+segal(iacctype,2,nsegal(iacctype))
- ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop)
- else
-c
-c netgain<0, must remove segments. Use same coding but reverse order,
-c work from bottom up
-c
- segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop)
- segrb(2,ibelowtop+netgain) =
- * nolev+segal(iacctype,2,nsegal(iacctype))
- ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop)
- do 12 isegrb = ibelowtop+1 , nsegrb
- segrb(1,isegrb+netgain) = segrb(1,isegrb)
- segrb(2,isegrb+netgain) = segrb(2,isegrb)
- ksegrb(isegrb+netgain) = ksegrb(isegrb)
-12 continue
- end if
-c
-c Insert new segments
-c
- do 8 isega = 1 , nsegal(iacctype)-1
- segrb(1,ibelowbot+isega) = shift+segal(iacctype,1,isega)
- segrb(2,ibelowbot+isega) = nolev+segal(iacctype,2,isega)
- if (mainnote) then
- ksegrb(ibelowbot+isega) = 0
- else
- ksegrb(ibelowbot+isega) = micrd(iwa)
- end if
-8 continue
-c
-c Update number of barrier segments
-c
- nsegrb = nsegrb+netgain
-cc
-cc Temporary printout for boundary segments as built up
-cc
-c write(15,'()')
-c write(15,'(a/(2f8.2,i5))')' y x kseg',
-c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb)
-c write(15,'(a/(2i5))')' micrd isetshft',
-c * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa)
-cc
-1 continue ! next accidental
- if (lasttime .and. .not.twooftwo) then
-c
-c This is the final call on the pre-ask pass, so compute left-shift rqmt.
-c
- icashft = nint(-20*shiftmin)
- end if
-cc
-cc Temporary printout for boundary segments
-cc
-c if (twooftwo) then
-c write(15,'()')
-c write(15,'(a/(2f8.2,i5))')' y x kseg',
-c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb)
-c write(15,'(a/(2i5))')' micrd isetshft',
-c * (micrd(iwa),isetshft(iwa),iwa=1,naccid)
-c end if
-cc
- return
- end
- subroutine crdaccs(nacc,ipl,irest,naccid,kicrd,nolevm,
- * levmaxacc,levminacc,icrdot0,twooftwo,icashft)
-c
-c nacc = accidental bitmap for main note
-c naccid = # of accid's in chord
-c kicrd = array with icrd #'s for notes w/ acc's, 0=>main note
-c nolevm = level of main note
-c
-c This is called once per multi-accidental chord. In here, loop over all
-c permutations of the order of accidental as stored in kicrd. Each time thru
-c loop, call crdacc once, get rms shift. Only save permutation and rms value
-c if it is less than old value.
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
-c
-c Make consistent? 120106
-c integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50)
- integer*4 kicrd(10),iperm(7),micrd(10),ipermsav(7),ksegrb0(50)
- real*4 segrb0(2,50)
- logical btest,tagged,manual,lshift,twooftwo
-cc
-cc Temporary printout of level-rankings
-cc
-c write(15,'()')
-c do 98 iacc = 1 , naccid
-c if (kicrd(iacc) .eq. 0) then
-c write(15,'(3i5)')nolevm,icrdot0
-c else
-c write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12),
-c * igetbits(icrdot(kicrd(iacc)),3,27)
-c end if
-c98 continue
-cc
-c
-c Initialize right-barrier
-c
- segrb0(1,1) = 0.
- segrb0(2,1) = -1000.
- segrb0(1,2) = 0.
- segrb0(2,2) = 1000.
- nsegrb0 = 2
- ksegrb0(1) = -1
- ksegrb0(2) = -1
-c
-c Search for left-shifted notes, Make up the initial right-barrier, which
-c will be good for all permutations.
-c irest()(27) is set if any notes are left-shifted
-c Must use ALL chord notes, not just ones w/ accid's.
-c
- if (btest(irest,27)) then
- do 15 icrd = icrd1-1, icrd2
- if (icrd .eq. icrd1-1) then
-c
-c Main note
-c
-c lshift = btest(ipl,8)
- lshift = btest(ipl,8) .or. btest(nacc,31)
- if (lshift) nolev = nolevm
- else
-c
-c Chord note
-c
- lshift = btest(icrdat(icrd),23)
-c if (lshift) nolev = igetbits(icrdat(icrd),7,12)
- if (lshift) then
- nolev = igetbits(icrdat(icrd),7,12)
- if (btest(nacc,31) .and. nolev.eq.nolevm+1) then
-c
-c This note is not really shifted, It is the upper of a 2nd with the main
-c note on an upstem, and Main note must be shifted.
-c nacc(31) signals the real truth.
-c
- lshift = .false.
- end if
- end if
- end if
- if (lshift) then
- do 16 isegrb = 1 , nsegrb0-1
- if (segrb0(2,isegrb+1) .gt. nolev-1) then
-c
-c Add this notehead to the right boundary here. Move all higher segs up 2.
-c
- do 17 iiseg = nsegrb0 , isegrb+1 , -1
- segrb0(1,iiseg+2) = segrb0(1,iiseg)
- segrb0(2,iiseg+2) = segrb0(2,iiseg)
- ksegrb0(iiseg+2) = ksegrb0(iiseg)
-17 continue
- go to 18
- end if
-16 continue
-18 continue
-c
-c Insert notehead into list. Set kseg=-2 to signal notehead shift.
-c
- iiseg = isegrb+1
- segrb0(1,iiseg) = -1.2
- segrb0(2,iiseg) = nolev-1.
- ksegrb0(iiseg) = -2
- segrb0(1,iiseg+1) = 0.
- segrb0(2,iiseg+1) = nolev+1.
- ksegrb0(iiseg+1) = -1
- nsegrb0 = nsegrb0+2
- end if
-15 continue
- end if
-c
-c Done setting right barrier for left-shifted noteheads
-c
- tagged = .false.
- manual = .false.
-c
-c Preprocess to check for manual shifts.
-c If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then
-c If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then
-c 1. Auto-shifting proceeds
-c 2. "A"-shifts add to autoshifts
-c 3. non-"A" shifts are ignored!
-c Else (>0 man shifts, none has "A")
-c No auto-ordering, No autoshifts, Observe all manual shifts.
-c End if
-c End if
-c
- maxmanshft = 0
- do 13 i = 1 , naccid
- if (kicrd(i) .eq. 0) then
-c
-c Main note
-c
- manshft = igetbits(nacc,7,10)
- if (manshft .ne. 0) then
- manual = .true.
- if (btest(nacc,29)) then
- tagged = .true.
- else
-c maxmanshft = max(maxmanshft,64-manshft)
- maxmanshft = max(maxmanshft,107-manshft)
- end if
- end if
- else
-c
-c Chord note
-c
- manshft = igetbits(icrdot(kicrd(i)),7,20)
- if (manshft .ne. 0) then
- manual = .true.
- if (btest(icrdat(kicrd(i)),29)) then
- tagged = .true.
- else
-c maxmanshft = max(maxmanshft,64-manshft)
- maxmanshft = max(maxmanshft,107-manshft)
- end if
- end if
- end if
-13 continue
- if (manual) then
- if (tagged) then
-c
-c zero out all untagged shifts
-c
- do 14 i = 1 , naccid
- if (kicrd(i) .eq. 0) then
- if (.not.btest(nacc,29)) call setbits (nacc,7,10,0)
- else
- if (.not.btest(icrdat(kicrd(i)),29))
- * call setbits (icrdot(kicrd(i)),7,20,0)
- end if
-14 continue
- else
-c
-c There are manual shifts but none tagged. Only proceed if "Ao" was entered
-c
- if (.not.btest(nacc,28)) then
- icashft = maxmanshft
- return
- end if
- end if
- end if
- if (btest(nacc,28)) then
-c
-c Take the accidentals in order as originally input, then exit.
-c
- call crdacc(nacc,naccid,kicrd,nolevm,rmsshift,.true.,
- * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
- return
-c end if
- else if (naccid .eq. 3) then
-c
-c Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd
-c then place in order top, bottom, middle.
-c
- do 20 i = 1 , 3
- if (kicrd(i) .eq. 0) then
- irank = icrdot0
- nolev = nolevm
- else
- irank = igetbits(icrdot(kicrd(i)),3,27)
- nolev = igetbits(icrdat(kicrd(i)),7,12)
- end if
- if (irank .eq. 1 ) then
- micrd(1) = kicrd(i)
- else
- micrd(5-irank) = kicrd(i)
- end if
- if (irank .eq. 2) then
- levmidacc = nolev
- end if
-20 continue
- if (levmaxacc.ne.levmidacc+1 .and.
- * levmidacc.ne.levminacc+1) then
- call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true.,
- * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
- return
- end if
- end if
- rmsmin = 100000.
-c
-c Initialize permutation array
-c
- do 7 i = 1 , naccid
- iperm(i) = i
-7 continue
-c
-c Start looping over permutations
-c
- do 8 ip = 1 , 5041
- if (ip .ne. 1) then
-c
-c Work the magic algorithm to get the next permutation
-c
- do 1 k = naccid-1 , 1 , -1
- if (iperm(k) .le. iperm(k+1)) go to 2
-1 continue
-c
-c If here, we just got the last permutation, so exit the loop over permutations
-c
- go to 10
-2 continue
- do 3 j = naccid , 1 , -1
- if (iperm(k) .le. iperm(j)) go to 4
-3 continue
-4 continue
- it = iperm(j)
- iperm(j) = iperm(k)
- iperm(k) = it
- is = k+1
- do 5 ir = naccid , 1 , -1
- if (ir .le. is) go to 6
- it = iperm(ir)
- iperm(ir) = iperm(is)
- iperm(is) = it
- is = is+1
-5 continue
-6 continue
- end if
-c
-c New we have a permutation. Take icrd values out of kicrd and put them into
-c micrd in the order of the permutation
-c
- do 9 i = 1 , naccid
- micrd(i) = kicrd(iperm(i))
-9 continue
-cc
-cc Temporary printout
-cc
-c write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid)
-cc
- call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.false.,
- * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
-cc
-cc Temporary printout
-cc
-c write(15,*)'perm done, rmsshift:',rmsshift
-cc
- if (rmsshift .lt. rmsmin) then
-c
-c Save this permutation, reset minrms
-c
- do 11 i = 1 , naccid
- ipermsav(i) = iperm(i)
- rmsmin = rmsshift
-11 continue
- end if
-8 continue
- print*,'Should not BEEEEEE here!'
- call stop1()
-10 continue
-c
-c Done looping, get info for the final choice
-c
- do 12 i = 1 , naccid
- micrd(i) = kicrd(ipermsav(i))
-12 continue
-cc
-cc Temporary printout
-cc
-c write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid)
-cc
- call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true.,
- * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
- return
- end
- subroutine doacc(ihshft,ivshft,notexq,lnote,nacc,nolev,ncm,caut)
- character*1 sq,chax
- character*3 acsymq
- character*8 noteq
- character*79 notexq
- logical btest,caut
- sq = chax(92)
- if (ihshft .eq. -107) ihshft=0
-cc
-cc If main note shifted left, so shift accid. Terminate below, when acc. is done.
-cc
- if (ihshft .ne. 0) then
-c
-c Accid must be shifted horizontally
-c
- if (ihshft .lt. 0) then
- notexq = sq//'loffset{'
- ihshft = -ihshft
- else
- notexq = sq//'roffset{'
- end if
- hshft = .05*ihshft
- if (hshft .lt. 1.) then
- write(notexq(10:12),'(f3.2)')hshft
- lnote = 12
- else
- write(notexq(10:13),'(f4.2)')hshft
- lnote = 13
- end if
- notexq = notexq(1:lnote)//'}{'//sq
- lnote = lnote+3
- else
- notexq = sq
- lnote = 1
- end if
- if (btest(nacc,3)) then
- notexq = notexq(1:lnote)//'big'
- lnote = lnote+3
- end if
- if (caut) then
-c
-c Cautionary accidental. Need to define bigcna,... in pmx.tex
-c
- notexq = notexq(1:lnote)//'c'
- lnote = lnote+1
- end if
- call accsym(nacc,acsymq,lacc)
- notexq = notexq(1:lnote)//acsymq(1:lacc)
- lnote = lnote+lacc
- noleva = nolev
- if (ivshft .ne. 0) noleva = noleva+ivshft-32
- call notefq(noteq,lnoten,noleva,ncm)
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (ihshft .ne. 0) then
-c
-c Terminate horizontal shift
-c
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- return
- end
- subroutine docrd(ivx,ip,nodu,ncm,iv,tnow,soutq,lsout,ulq,ibmcnt,
- * islur,nvmx,nv,beamon,nolevm,ihornb,nornb,stemlen,
- * dotxtup,nacc,irest)
- parameter (nm=24,mv=24576)
- integer*4 irest(nm,24)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- integer*2 mmidi,iinsiv
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- logical lowdot,dotxtup
- integer*4 ihornb(nm,24),nornb(nm)
- character*1 ulq(nm,9),chax
- character*7 nosymq
- character*8 noteq
- character*79 notexq,outq
- character*80 soutq
- logical btest,isleft,isright,beamon
- character*79 inameq
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig,
- * lnam(nm),inameq(nm)
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /commidisig/ midisig
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * maxdotmv(nm),ndotmv(nm),updot(nm,20),rtdot(nm,20)
-c
-c This subr. once produced notexq for entire chord. 10/18/97 altered to write
-c chord notes as we go. 10/22/97 find range of icrd first.
-c 2/25/98 moved rangefinding to precrd so done before slurs, so now
-c on entry, icrd1, icrd2 define range of icrd for this chord.
-c
-c Set counter (for this note) for chord notes present. Set notmain=T.
-c Will test for notmain=.true. in addmidi to tell whether to save pitch.
-c
- nmidcrd = 0
- notmain = .true.
- crdacc = .false.
- do 5 icrd = icrd1 , icrd2
- lnote = 0
- nolev = igetbits(icrdat(icrd),7,12)
-c
-c 3/8/03 save original pitch to use in midi, in case 2nds alter things.
-c
- nolevo = nolev
-c
-c Check for special situations with 2nds (see precrd).
-c
- if (btest(nacc,30) .and. nolev.eq.nolevm-1) then
-c
-c Upstem, 2nd with upper as main, interchange pitches,
-c rt-shift upper (now chord note). Lower (orig chord, now main)
-c if dotted, probably had shifted dot, dot parameters must be moved
-c from chord to main
-c
- nolev = nolevm
- if (btest(icrdat(icrd),26)) then
-c
-c Orig. chord note dot shift, must transfer to main.
-c
- icrdotsav = icrdot(icrd)
- icrdatsav = icrdat(icrd)
- if (btest(irest(ivx,ip),19)) then
-c
-c Main note (upper) had a dot shift, must move it to chord
-c
- call setbits(icrdat(icrd),1,26,1)
- call setbits(icrdot(icrd),7,0,
- * nint(updot(ivx,ndotmv(ivx)+1)*10)+64)
- call setbits(icrdot(icrd),7,7,
- * nint(rtdot(ivx,ndotmv(ivx)+1)*10)+64)
-c
-c May need to worry about other chord params (accid shefts etc) later
-c
- else
- icrdat(icrd) = ibclr(icrdat(icrd),26)
- end if
-c
-c We are adding a main note dot shift, so push any later ones back
-c
-
- if (.not.btest(irest(ivx,ip),19)) then
- maxdotmv(ivx) = maxdotmv(ivx)+1
- do 1 indm = maxdotmv(ivx) , ndotmv(ivx)+2 , -1
- updot(ivx,indm) = updot(ivx,indm-1)
- rtdot(ivx,indm) = rtdot(ivx,indm-1)
-1 continue
- end if
- irest(ivx,ip) = ibset(irest(ivx,ip),19)
- updot(ivx,ndotmv(ivx)+1) = 0.1*(iand(127,icrdotsav)-64)
- rtdot(ivx,ndotmv(ivx)+1) =
- * 0.1*(iand(127,ishft(icrdotsav,-7))-64)
- end if
- else if (btest(nacc,31) .and. nolev.eq.nolevm+1) then
-c
-c Downstem, 2nd with lower as main, interchange pitches,
-c left-shift lower (now chord note). Lower (orig main, now chord)
-c probably had shifted dot, dot parameters must be moved from
-c main to chord
-c
- nolev = nolevm
- if (btest(irest(ivx,ip),19)) then
- icrdotsav = icrdot(icrd)
- icrdatsav = icrdat(icrd)
- icrdat(icrd) = ibset(icrdat(icrd),26)
-c bits in icrdot
-c 0-6 10*abs(vertical dot shift in \internote) + 64
-c 7-13 10*abs(horizontal dot shift in \internote) + 64
-c Assuming >0 for now!
- call setbits(icrdot(icrd),7,0,
- * nint(updot(ivx,ndotmv(ivx)+1)*10)+64)
- call setbits(icrdot(icrd),7,7,
- * nint(rtdot(ivx,ndotmv(ivx)+1)*10)+64)
-c
-c Must also set dot shift for (now) main note (orig. chord note).
-c
- if (btest(icrdatsav,26)) then
- updot(ivx,ndotmv(ivx)+1) = 0.1*(iand(127,icrdotsav)-64)
- rtdot(ivx,ndotmv(ivx)+1) =
- * 0.1*(iand(127,ishft(icrdotsav,-7))-64)
- else
-c
-c No dot move on original chord (now main) note,
-c
- updot(ivx,ndotmv(ivx)+1) = 0.
- rtdot(ivx,ndotmv(ivx)+1) = 0.
- end if
- end if
- end if
-c
-c Lower dot for lower-voice notes?. Conditions are:
-c 1. Dotted time value
-c 2. Lower voice of two
-c 3. Note is on a line
-c 4. Not a rest (cannot be a rest in a chord!)
-c. 5. Flag (lowdot) is set to true
-c
- if (lowdot .and. nvmx.eq.2 .and. ivx.le.nv) then
- if (2**log2(nodu).ne.nodu .and. mod(nolev-ncm,2).eq.0) then
- if (btest(icrdat(icrd),26)) then
-c
-c Note already in movdot list. Drop by 2.
-c
- call setbits(icrdot(icrd),7,0,
- * igetbits(icrdot(icrd),7,0)-20)
- else
-c
-c Not in list so just move it right now
-c
- call dotmov(-2.,0.,soutq,lsout,igetbits(islur,1,3))
- end if
- end if
- end if
- if (btest(icrdat(icrd),26)) then
-c
-c Move the dot. Basic call for chord notes, not main note.
-c
- updotc = 0.1*(iand(127,icrdot(icrd))-64)
- rtdotc = 0.1*(iand(127,ishft(icrdot(icrd),-7))-64)
- call dotmov(updotc,rtdotc,soutq,lsout,igetbits(islur,1,3))
- end if
- isleft = btest(icrdat(icrd),23)
- isright = btest(icrdat(icrd),24)
-c
-c Check for ornament in chord.
-c
- if (icrdorn(icrd) .gt. 0) then
- call putorn(icrdorn(icrd),nolev,nolevm,nodu,nornb,ulq,
- * ibmcnt,ivx,ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,
- * ip,0,beamon,.true.)
- call addstr(outq,lout,soutq,lsout)
- end if
-c
-c Chord-note symbol. First check for breve
-c
- if (nodu .eq. 128) then
- nosymq = chax(92)//'zbreve'
- lsym = 7
- else
-c
-c Not a breve chord. Get first letters in chord-note symbol
-c
- if (isleft) then
- nosymq = chax(92)//'l'
- else if (isright) then
- nosymq = chax(92)//'r'
- else
- nosymq = chax(92)//'z'
- end if
- if (nodu .ge. 64) then
- nosymq = nosymq(1:2)//'w'
- else if (nodu .ge. 32) then
- nosymq = nosymq(1:2)//'h'
- else
- nosymq = nosymq(1:2)//'q'
- end if
- if (2**log2(nodu).eq.nodu .and. .not.dotxtup) then
- lsym = 3
- else if (.not.btest(islur,3) .or. dotxtup) then
-c
-c Single dot
-c
- nosymq = nosymq(1:3)//'p'
- lsym = 4
- else
-c
-c Double dot
-c
- nosymq = nosymq(1:3)//'pp'
- lsym = 5
- end if
- end if
- if (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) then
-c
-c Accidental and not MIDI-only. Build up bits 0-3 of nacc
-c
- nactmp = igetbits(icrdat(icrd),3,20)
-c
-c Kluge for bigness. Only means 'As' has not been issued
-c
- if (bacfac .ne. 1.e6) nactmp = nactmp+8
- call doacc(igetbits(icrdot(icrd),7,20)-107,
- * igetbits(icrdot(icrd),6,14),
-c * notexq,lnote,nactmp,nolev,ncmid(iv,ip))
-c Get original nolev, not altered to deal with 2nds
- * notexq,lnote,nactmp,igetbits(icrdat(icrd),7,12),
-c * ncmid(iv,ip))
- * ncmid(iv,ip),btest(icrdat(icrd),31))
- notexq = notexq(1:lnote)//nosymq
- crdacc = .true.
- else
- notexq = nosymq
- end if
- lnote = lnote+lsym
-c
-c Get note name (again if accid, due to possible octave jump)
-c
- call notefq(noteq,lnoten,nolev,ncm)
- if (lnoten.eq.1) call addblank(noteq,lnoten)
-c
-c Put in note name
-c
- notexq = notexq(1:lnote)//noteq
- lnote = lnote+lnoten
- if (btest(icrdat(icrd),25)) then
-c
-c Arpeggio signal
-c
- call putarp(tnow,ivx,ip,nolev,ncm,soutq,lsout)
- end if
- call addstr(notexq,lnote,soutq,lsout)
- if (ismidi) then
-c
-c Here is where we collect MIDI pitch info for the chord note. By checking
-c notmain, addmidi(...) knows to just compute the
-c pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi()
-c for MAIN note, will put in note codes for all chord notes + main note.
-c
- kv = 1
- if (ivx .gt. iv) kv=2
- nmidcrd = nmidcrd+1
- if (nmidcrd .gt. 20) then
- print*
- print*,'21 chord notes is too many for midi processor'
- call stop1()
- end if
-c
-c Use original saved pitch level, unaltered by 2nds logic.
-c
- call addmidi(midchan(iv,kv),nolevo+miditran(instno(iv)),
- * igetbits(icrdat(icrd),3,20),midisig,1.,
- * .false.,.false.)
- end if
-5 continue
- notmain = .false.
- return
- end
- subroutine dodyn(ivx,ip,nolev,ncm,ipl,islur,irest,nvmx,nv,
- * beamon,ihornb,nornb,ulq,ibmcnt,nostem,soutq,lsout)
- parameter (nm=24)
-c
-c Inputs are array *elements* except ihornb,nornb,ulq
-c
- common /commus/ musize,whead20
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- logical btest,beamon,upstem,nostem
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical fontslur,upslur,WrotePsslurDefaults
- character*1 udqq,chax,ulq(nm,9)
- character*4 dynstrq
- character*5 numpq
- character*48 dyntablq,tempq
- character*79 notexq
- character*80 soutq
- integer*4 ihornb(nm,24),nornb(nm),idynn(10)
- common /comhair/ ihairuse,idhair(nm)
- data dyntablq /'ppppppp pp p mp mf f fp sfz ff fff ffff'/
- numdyn = 0
-c
-c Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values
-c in idynn(1...4)
-c
- do 1 idyn = 1 , ndyn
- ivxtent = iand(idyndat(idyn),15)
- * +16*igetbits(idynda2(idyn),1,10)
- if (ivxtent .eq. ivx) then
- iptent = igetbits(idyndat(idyn),8,4)
- if (iptent .eq. ip) then
- numdyn = numdyn+1
- idynn(numdyn) = idyn
- else if (iptent .gt. ip) then
-c
-c I don't think there are any more possible for this ivx,ip, so exit loop
-c
- go to 2
- end if
- end if
-1 continue
-2 continue
-c
-c At this point there is a list of idyn's in idynn(1...numdyn)
-c Compute level, and stem-dir'n-based horizontal tweaks
-c
- hoffsd = 0.
-c
-c Set upstem to false as default
-c
- upstem = .false.
- if (btest(irest,0)) then
-c
-c It's a rest. Assume it doesn't go below the staff
-c
- lbot = ncm-4
- else if (.not.beamon) then
- if (udqq(nolev,ncm,islur,nvmx,ivx,nv).eq.'u' .or. nostem) then
- upstem = .true.
- if (.not.btest(ipl,10)) then
- lbot = min(nolev-1,ncm-4)
- else
- lbot = min(minlev-1,ncm-4)
- end if
- else
- hoffsd = -.5
- if (.not.btest(ipl,10)) then
- lbot = min(nolev-7,ncm-4)
- else
- lbot = min(minlev-7,ncm-4)
- end if
- end if
- else
- if (ulq(ivx,ibmcnt) .eq. 'u') then
- upstem = .true.
- if (.not.btest(ipl,10)) then
- lbot = min(nolev-1,ncm-4)
- else
- lbot = min(minlev-1,ncm-4)
- end if
- else
- hoffsd = -.5
-c
-c 171230 Desperation
-c lbot = ihornb(ivx,nornb(ivx))+1
- if (nornb(ivx).eq.0) then
- lbot = 1
- else
- lbot = ihornb(ivx,nornb(ivx))+1
- end if
- if (lbot .eq. 1) then
-c
-c Kluge for non-beamed, down xtup, for which ihorb was never set.
-c Assumes stem is shortened.
-c
- lbot = nolev-5
- end if
- nornb(ivx) = nornb(ivx)+1
- end if
- end if
- lbot = lbot-5
- jtxtdyn1 = 1
-c
-c Now ready to loop over current dyn's
-c
- do 3 icntdyn = 1 , numdyn
- idynd = idyndat(idynn(icntdyn))
- idynd2 = idynda2(idynn(icntdyn))
- idno = igetbits(idynd,4,12)
-c ivx = iand(15,idynd)
- ivx = iand(15,idynd)+16*igetbits(idynd2,1,10)
-c
-c Build the command into notex in stages. Insert name & rq'd args in order:
-c
-c Command name
-c hpstrt, hpcend, hpdend, pmxdyn
-c ivx
-c X X X
-c level
-c X X X
-c hoff
-c X X X X
-c d-mark
-c X
-c
- if (idno .eq. 0) then
-c
-c Text-dynamic
-c
- notexq = chax(92)//'txtdyn'
- lnote = 7
- else if (idno .le. 12) then
-c
-c Letter-group
-c
- notexq = chax(92)//'pmxdyn'
- lnote = 7
- else if (fontslur) then
- lnote = 7
- if (idno .eq. 13) then
-c
-c Start a font-based hairpin
-c
- notexq = chax(92)//'hpstrt'
- else if (idno .eq. 14) then
-c
-c End crescendo
-c
- notexq = chax(92)//'hpcend'
- else
-c
-c End decrescendo
-c
- notexq = chax(92)//'hpdend'
- end if
-c
-c Put in voice number as ID for font-based hairpin
-c
- if (ivx .le. 9) then
- notexq = notexq(1:lnote)//char(48+ivx)
- lnote = lnote+1
- else if (ivx .le. 19) then
- notexq = notexq(1:lnote)//'{1'//char(38+ivx)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//char(28+ivx)//'}'
- lnote = lnote+4
- end if
- else
-c
-c Postscript hairpins
-c
- lnote = 7
- if (idno .eq. 13) then
- notexq = chax(92)//'Icresc'
- else if (idno .eq.14) then
- notexq = chax(92)//'Idecresc'
- lnote = 9
- else
- notexq = chax(92)//'Tcresc'
- end if
- if (idno .le. 14) then
-c
-c Get and record ID no for start of ps hairpin
-c Find first unused ID
-c
- do 8 idh = 1 , 24
- if (.not.btest(ihairuse,idh)) go to 9
-8 continue
- call printl('Bad place in putdyn, call Dr. Don')
- call stop1()
-9 continue
- ihairuse = ibset(ihairuse,idh)
- idhair(ivx) = idh
- else
-c
-c Unrecord ID no for end of ps hairpin
-c
- call setbits(ihairuse,1,idhair(ivx),0)
- end if
-c
-c Write ID # for start or end of ps hairpin
-c
- idh = idhair(ivx)
- if (idh .le. 9) then
- notexq = notexq(1:lnote)//char(48+idh)
- lnote = lnote+1
- else if (idh .le. 19) then
- notexq = notexq(1:lnote)//'{1'//char(38+idh)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//char(28+idh)//'}'
- lnote = lnote+4
- end if
- end if
-c
-c Begin setting level
-c
- lbot1 = lbot
- if (idno.gt.0 .and. idno.le.5) then
-c
-c All letters are short so raise a bit.
-c
- lbot1 = lbot1+1
- else if (idno .ge. 13) then
- lbot1 = lbot1+2
- end if
-c
-c Convert so reference is bottom line
-c
- lbot1 = lbot1-ncm+4
- if ((fontslur.and.idno.eq.13) .or.
- * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then
-c
-c Hairpin start. Save level and user-tweak before applying user tweak.
-c
- levdsav(ivx) = lbot1
- levhssav(ivx) = 0
- if (btest(idynd,16)) levhssav(ivx) = -64+igetbits(idynd,7,17)
- else if ((fontslur.and.idno.ge.14) .or. idno.eq.15) then
-c
-c Hairpin end; Compare level with saved start level before user-tweaks
-c
- lbot1 = min(lbot1,levdsav(ivx))
-c
-c Save pre-tweak level
-c
- lpretweak = lbot1
- end if
-c
-c Check for user-defined vertical tweak
-c
- if (btest(idynd,16)) lbot1 = lbot1-64+igetbits(idynd,7,17)
-c
-c Now horizontal stuff
-c
- hoff = hoffsd
-c
-c Some special horizontal tweaks
-c
- if (upstem .and. idno.gt.0 .and.
- * (idno.le.4 .or. idno.eq.8 .or. idno.eq.9)) hoff = hoff+.4
-c
-c User-defined tweaks
-c
- if (btest(idynd2,0))
- * hoff = hoff+(igetbits(idynd2,9,1)-256)*.1
- if (numdyn .gt. 1) then
-c
-c Horizontal-interaction-based tweaks.
-c
-c Cases:
-c numdyn type1 type2 type3 data used
-c 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12)
-c 2 hrpnend wrd-grp - ivowg,hoh2
-c 2 hrpnend hrpnstrt - hoh2h1(1...2)
-c 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1
-c
- if (idno.gt.0 .and. idno.le.12) then
-c
-c Word-group, may need vertical tweak to line up.
-c
- lbot1 = lbot1+ivowg(idno)
-c
-c Protecting against hp start-stop on same note
-c
- else if (((fontslur.and.idno.ge.14).or.idno.eq.15)
- * .and. icntdyn.lt.numdyn) then
-c
-c Hairpin ending, check next type
-c
- if ((fontslur .and.
- * igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13)
- * .or. (.not.fontslur .and.
- * ((igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13)
- * .or.
- * (igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.14))))
- * then
-c
-c Hairpin end then hairpin start, no words, (remember dealing with end now)
-c
- hoff = hoff+hoh2h1(1)
- else
-c
-c Hairpin end then word-group, need idno for w-g to set hp offset
-c
- hoff = hoff +
- * hoh2(igetbits(idyndat(idynn(icntdyn+1)),4,12))
- end if
-c
-c Protecting against hp start-stop on same note
-c
- else if (icntdyn.gt.1 .and. idno.gt.0 .and.
- * ((fontslur.and.idno.lt.14).or.
- * (.not.fontslur.and.idno.lt.15))) then
-c
-c Hairpin start, check prior type
-c
- if ((fontslur.and.
- * igetbits(idyndat(idynn(icntdyn-1)),4,12).ge.14)
- * .or.
- * (.not.fontslur.and.
- * igetbits(idyndat(idynn(icntdyn-1)),4,12).eq.15))
- * then
-c
-c Hairpin end then hairpin start, (remember dealing with start now)
-c
- hoff = hoff+hoh2h1(2)
- else
-c
-c Hairpin start after word-group, need idno for w-g to set hp offset
-c
- hoff = hoff+
- * hoh1(igetbits(idyndat(idynn(icntdyn-1)),4,12))
- end if
- end if
- end if
-c
-c End of if-block for 2- or 3-way interactions.
-c
- if ((.not.fontslur) .and. idno.ge.13)
-c
-c Slur font and hairpin. Add hoff, and change from \interneote to \qn at width
-c
- * hoff = (hoff+.5)*6./2.5
-c
-c Position corrections all done now. Put in the level.
-c
- if ((fontslur.and.idno.eq.13) .or.
- * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then
-c
-c Hairpin start.
-c
- if (.not.fontslur) then
-c
-c Postscript hairpin start...inset placeholder for start level.
-
- notexq = notexq(1:lnote)//'{ }'
- lnote = lnote+5
- end if
- else
-c
-c Insert actual level in all cases except hairpin start
-c Create string with level in it
-c
- if (lbot1 .gt. 9) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else if (lbot1 .gt. -1) then
- numpq = char(48+lbot1)
- lnumpq = 1
- else if (lbot1 .gt. -10) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else
- numpq = '{'
- write(numpq(2:4),'(i3)')lbot1
- numpq = numpq(1:4)//'}'
- lnumpq = 5
- end if
-c
-c Level has now been computed and stored in numpq
-c Append the level
-c
- notexq = notexq(1:lnote)//numpq(1:lnumpq)
- lnote = lnote+lnumpq
- end if
- if (abs(hoff) .lt. .001) then
-c
-c No horiz offset
-c
- notexq = notexq(1:lnote)//'0'
- lnote = lnote+1
- else
-c
-c Horizontal tweak
-c
- lform = lfmt1(hoff)
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- write(notexq(lnote+1:lnote+lform),
- * '(f'//chax(48+lform)//'.1)')hoff
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- if (idno .eq. 0) then
-c
-c text-dynamic. Find the string and append it
-c
- do 4 jtxtdyn = jtxtdyn1 , ntxtdyn
-c ivxip = ivx+16*ip
- ivxip = ivx+32*ip
- if (ivxip .eq. ivxiptxt(jtxtdyn)) go to 5
-4 continue
- call printl('Abnormal stop in putdyn')
- call stop1()
-5 continue
- ltxtdyn = lenstr(txtdynq(jtxtdyn),128)
-c
-c Font size based on musicsize
-c
-c if (musize .eq. 20) then
-c notexq = notexq(1:lnote)//'{'//char(92)//'medtype'
-c * //char(92)//'it '
-c lnote = lnote+13
-c else if (musize .eq. 16) then
-c notexq = notexq(1:lnote)//'{'//char(92)//'normtype'
-c * //char(92)//'it '
-c lnote = lnote+14
-c else if (musize .eq. 24) then
-c notexq = notexq(1:lnote)//'{'//char(92)//'bigtype'
-c * //char(92)//'it '
-c lnote = lnote+13
-c else if (musize .eq. 29) then
-c notexq = notexq(1:lnote)//'{'//char(92)//'Bigtype'
-c * //char(92)//'it '
-c lnote = lnote+13
-c end if
-c
-c Do this to insert 1st 2 args of \txtdyn, allow 3rd to be longer (on next line)
-c
- call addstr(notexq(1:lnote),lnote,soutq,lsout)
- if (musize .eq. 20) then
- notexq = '{'//char(92)//'medtype'//char(92)//'it '
- lnote = 13
- else if (musize .eq. 16) then
- notexq = '{'//char(92)//'normtype'//char(92)//'it '
- lnote = 14
- else if (musize .eq. 24) then
- notexq = '{'//char(92)//'bigtype'//char(92)//'it '
- lnote = 13
- else if (musize .eq. 29) then
- notexq = '{'//char(92)//'Bigtype'//char(92)//'it '
- lnote = 13
- end if
-c
- notexq = notexq(1:lnote)//txtdynq(jtxtdyn)(1:ltxtdyn)//'}'
- lnote = lnote+ltxtdyn+1
-c
-c Reset jtxtdyn1 just in case >1 txtdyn on same note.
-c
- jtxtdyn1 = jtxtdyn+1
- else if (idno .le. 12) then
-c
-c Letter-group dynamic. Append the letter-group command
-c
- id = 4*idno
- dynstrq = dyntablq(id-3:id)
- id = lenstr(dynstrq,4)
- notexq = notexq(1:lnote)//chax(92)//dynstrq(1:id)
- lnote = lnote+1+id
- end if
- call addstr(notexq(1:lnote),lnote,soutq,lsout)
- if ((.not.fontslur).and.idno.eq.15) then
-c
-c PS slurs on, hairpin is ending. Go back and set height at beginning.
-c Add user-defined tweak to default level
-c
- lbot1 = lpretweak+levhssav(ivx)
- if (lbot1 .gt. 9) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else if (lbot1 .gt. -1) then
- numpq = char(48+lbot1)
- lnumpq = 1
- else if (lbot1 .gt. -10) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else
- numpq = '{'
- write(numpq(2:4),'(i3)')lbot1
- numpq = numpq(1:4)//'}'
- lnumpq = 5
- end if
-c
-c Construct string to search backwards for placeholder
-c
- if (idh .le. 9) then
- tempq = 'cresc'//char(48+idh)//'{ }'
- ltemp = 11
- else if (idh .le. 19) then
- tempq = 'cresc'//'{1'//char(38+idh)//'}{ }'
- ltemp = 14
- else
- tempq = 'cresc'//'{2'//char(28+idh)//'}{ }'
- ltemp = 14
- end if
- write(11,'(a)')soutq(1:lsout)//'%'
- lsout = 0
- call backfill(11,tempq,ltemp,
- * tempq(1:ltemp-5)//numpq(1:lnumpq),ltemp-5+lnumpq)
- end if
-3 continue
-c
-c Shrink arrays, decrease ndyn 111109
-c
- do 6 icntdyn = numdyn, 1 , -1
- do 7 jdyn = idynn(icntdyn) , ndyn-1
- idyndat(jdyn) = idyndat(jdyn+1)
- idynda2(jdyn) = idynda2(jdyn+1)
-7 continue
- ndyn = ndyn-1
-6 continue
- end
- subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,nacc,ig,ipl,
- * farend,
- * beamon,nolev,ncmidx,islur,nvmx,nv,ibmcnt,tnote,ulq,instno)
-c
-c ip will be one LESS than current note, for way-after's before bar-end,
-c It is only used to find ig.
-c ig is returned to makeabar in case there's a slur that needs to be ended
-c
- parameter (nm=24)
- logical beamon,stemup
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comoct/ noctup
- logical upg,slurg,slashg,bar1syst,upslur,btest,isgaft,iswaft,
- * normsp,farend,fontslur,WrotePsslurDefaults
- real*4 ptgr(37)
- character*80 soutq
- character*128 litq
- character*79 notexq
- character*20 voltxtq
- character*10 figq
- character*8 noteq,noteqGA
- character*3 acsymq
- character*1 sq,chax,udqq,ulq(nm,9)
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2,ivvfig(2,74)
- sq = chax(92)
- isgaft = btest(ipl,29)
- iswaft = btest(ipl,31)
- normsp = .not. isgaft
-c
-c Find ig.
-c
- do 120 ig = 1 , ngrace
- if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 121
-120 continue
- print*,'Problem finding grace index in dograce'
- stop
-121 continue
- ngs = ngstrt(ig)
- mg = multg(ig)
-c wheadpt1 = wheadpt*fullsize(ivx)
- wheadpt1 = wheadpt*fullsize(instno)
-c
-c For way-after-graces at end of bar, must set the octave.
-c
- if (farend) then
- noctup = 0
- if (ncm .eq.23) noctup = -2
- end if
- if (slurg(ig) .and. .not.iswaft .and..not.isgaft) then
- if (listslur .eq. 16777215) then
- print*
- print*,'You defined the twentyfifth slur, one too many!'
- write(15,'(/,a)')
- * 'You defined the twentyfifth slur, one too many!'
- call stop1()
- end if
-c
-c Slur on fore-grace. Get index of next slur not in use, from 23 down.
-c
- ndxslur = log2(16777215-listslur)
-
- end if
- if (nng(ig) .eq. 1) then
-c
-c Single grace.
-c
- if (normsp) then
-c
-c Anything but GA
-c
- call addstr(sq//'shlft',6,soutq,lsout)
- niptgr = nint(ptgr(ig))
-c
-c Empirical tweak for postscript.
-c
-C if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3)
-c++
- if (niptgr .lt. 10) then
- call addstr(chax(48+niptgr)//'{',2,soutq,lsout)
- else if (niptgr .lt. 100) then
- write(notexq(1:2),'(i2)')niptgr
- call addstr('{'//notexq(1:2)//'}{',5,soutq,lsout)
- else
- print*,
- * 'Call Dr. Don if you really want grace note group > 99 pt'
- stop
- end if
- else
- call addstr(sq//'gaft{1.5}{',11,soutq,lsout)
-c
-c GA. Compute aftshft, for later use.
-c
- aftshft = grafac
- if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+agc1fac
- aftshft = aftshft*wheadpt
- end if
- if (slurg(ig) .and. .not.isgaft .and..not.iswaft) then
-c
-c Start slur on pre-grace. No accounting needed since will be ended very soon.
-c
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- if (fontslur) then
- if (upg(ig)) then
- call addstr(sq//'islurd',7,soutq,lsout)
- else
- call addstr(sq//'isluru',7,soutq,lsout)
- end if
- else
-c
-c Start Postscript slur.
-c
- if (upg(ig)) then
- call addstr(sq//'isd',4,soutq,lsout)
- else
- call addstr(sq//'isu',4,soutq,lsout)
- end if
- end if
-c
-c Print slur number, 23-ndxslur
-c
- lnote = 0
- if (23-ndxslur .lt. 10) then
-c notexq = notexq(1:lnote)//chax(59-ndxslur)
- notexq = chax(71-ndxslur)
- lnote = 1
- else if (23-ndxslur .lt. 20) then
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
- notexq = '{1'//chax(61-ndxslur)//'}'
- lnote = 4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = 4
- end if
- call addstr(notexq(1:lnote)//noteq(1:lnoten),
- * lnote+lnoten,soutq,lsout)
- if (.not.fontslur) then
-c
-c Horizontal tweaks for postscript slur on single grace
-c
- stemup = .true.
- if (upg(ig)) then
-c
-c Check for up-grace + down stem. Get stem direction
-c
- if (.not.beamon) then
-c
-c Separate note. Get stem direction.
-c
- stemup = udqq(nolev,ncmidx,
- * islur,nvmx,ivx,nv) .eq. 'u'
- else
-c
-c In a beam
-c
- stemup = ulq(ivx,ibmcnt) .eq. 'u'
- end if
-c
-c Stop the shift if whole note
-c
- stemup = stemup .or. tnote.gt.63
- end if
- if (stemup) then
- call addstr('{-.3}',5,soutq,lsout)
- else
- call addstr('{-.8}',5,soutq,lsout)
- end if
- end if
- end if
- if (naccg(ngs) .gt. 0) then
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
-c
-c Save for checking octave shifts in GA
-c
- if (isgaft) then
- lnotenGA = lnoten
- noteqGA = noteq
- end if
-c
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call accsym(naccg(ngs),acsymq,lacc)
- call addstr(sq//'big'//acsymq(1:lacc)//
- * noteq(1:lnoten),4+lacc+lnoten,soutq,lsout)
- end if
- if (slashg(ig)) then
- notexq = sq//'grc'
- lnote = 4
- else if (mg .eq. 0) then
- notexq = sq//'zq'
- lnote = 3
- else
- notexq = sq//'zc'
- do 61 i = 2 , mg
- notexq = notexq(1:i+1)//'c'
-61 continue
- lnote = mg+2
- end if
- if (upg(ig)) then
- notexq = notexq(1:lnote)//'u'
- else
- notexq = notexq(1:lnote)//'l'
- end if
- call addstr(notexq,lnote+1,soutq,lsout)
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
-c
- if (isgaft .and. naccg(ngs).eq.0) then
- lnotenGA = lnoten
- noteqGA = noteq
- end if
-c
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call addstr(noteq,lnoten,soutq,lsout)
- if (slashg(ig)) call addstr(sq//'off{-'//sq//
- * 'noteskip}',16,soutq,lsout)
-c
-c Above code needed since slashg causes spacing
-c
- if (slurg(ig) .and. (iswaft.or.isgaft)) then
-c
-c Terminate slur on single after-grace
-c
- ndxslur = igetbits(ipl,5,23)
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- call addstr(sq//'tslur',6,soutq,lsout)
-c
-c Print 24-ndxslur
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c call addstr(chax(59-ndxslur)//noteq(1:lnoten),
- call addstr(chax(71-ndxslur)//noteq(1:lnoten),
- * 1+lnoten,soutq,lsout)
- else if (23-ndxslur .lt. 20) then
- call addstr('{2'//chax(61-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- else
-c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten),
- call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- end if
- slurg(ig) = .false.
- listslur = ibclr(listslur,ndxslur)
- end if
- call addstr('}',1,soutq,lsout)
-c
-c+++ Try to fix loss of octave with single gaft
-c
- if (isgaft) then
- itrans = 0
- do 1 i = 1 , lnotenGA
- if (noteqGA(i:i) .eq. chax(39)) then
- itrans = itrans+7
- else if (noteqGA(i:i) .eq. chax(96)) then
- itrans = itrans-7
- end if
-1 continue
- if (itrans. eq. -14) then
- call addstr(sq//'advance'//sq//'transpose-14',21,
- * soutq,lsout)
- else if (itrans .eq. -7) then
- call addstr(sq//'advance'//sq//'transpose-7',20,
- * soutq,lsout)
- else if (itrans .eq. 7) then
- call addstr(sq//'advance'//sq//'transpose7',19,
- * soutq,lsout)
- else if (itrans .eq. 14) then
- call addstr(sq//'advance'//sq//'transpose14',20,
- * soutq,lsout)
- end if
- end if
- else
-c
-c Multiple grace. Put in literally. Compute beam stuff
-c
- sumx = 0.
- sumy = 0.
- sumxy = 0.
- sumxx = 0.
- sumyy = 0.
- x = 0.
- do 118 ing = ngs , ngs+nng(ig)-1
- if (ing.gt.ngs .and. naccg(ing).gt.0) x = x+acgfac
- y = nolevg(ing)
- sumx = sumx + x
- sumy = sumy + y
- sumxy = sumxy + x*y
- sumxx = sumxx + x*x
- sumyy = sumyy + y*y
- x = x+emgfac
-118 continue
- delta = nng(ig)*sumxx-sumx*sumx
- em = (nng(ig)*sumxy-sumx*sumy)/delta
- islope = nint(0.5*em*gslfac)
- if (iabs(islope) .gt. 9) islope = isign(9,islope)
- beta = (sumy-islope/gslfac*sumx)/nng(ig)
- nolev1 = nint(beta)
-c
-c Back up
-c
- notexq = sq//'settiny'//sq//'off{'
- if (normsp) then
- write(notexq(14:18),'(a1,f4.1)')'-',ptgr(ig)
- call addstr(notexq(1:18)//'pt}',21,soutq,lsout)
- finalshift = ptgr(ig)
- else
- aftshft = wheadpt*1.33
- if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+wheadpt*0.5
- write(notexq(14:17),'(f4.1)')aftshft
- call addstr(notexq(1:17)//'pt}'//sq//'bsk',24,soutq,lsout)
- end if
-c
-c Start the beam
-c
- notexq = sq//'ib'
- do 119 ing = 2 , mg
- notexq = notexq(1:ing+1)//'b'
-119 continue
- if (upg(ig)) then
- notexq = notexq(1:mg+2)//'u'
- else
- notexq = notexq(1:mg+2)//'l'
- end if
- notexq = notexq(1:mg+3)//'0'
-c
-c Get starting note for beam
-c
- call notefq(noteq,lnoten,nolev1,ncm)
- call addstr(notexq(1:mg+4)//noteq(1:lnoten),
- * mg+4+lnoten,soutq,lsout)
-c
-c Put in the slope
-c
- if (islope .ge. 0) then
- call addstr(chax(48+islope),1,soutq,lsout)
- else
- call addstr('{-'//chax(48-islope)//'}',4,soutq,lsout)
- end if
-c
-c Start a slur on multiple fore-grace
-c
- if (slurg(ig) .and. .not.isgaft .and. .not.iswaft) then
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- if (fontslur) then
- if (upg(ig)) then
- call addstr(sq//'islurd',7,soutq,lsout)
- else
- call addstr(sq//'isluru',7,soutq,lsout)
- end if
- else
-c
-c Need a tweak for postscript slur
-c
- if (upg(ig)) then
- call addstr(sq//'isd',4,soutq,lsout)
- else
- call addstr(sq//'isu',4,soutq,lsout)
- end if
- end if
-c
-c Print 23-ndxslur
-c
- if (23-ndxslur .lt. 10) then
- call addstr(chax(71-ndxslur)//noteq(1:lnoten),1+lnoten,
- * soutq,lsout)
- else if (23-ndxslur .lt. 2) then
- call addstr('{1'//chax(61-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- else
- call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- end if
-c
-c Put in tweak for postscript slur
-c
- if (.not.fontslur) call addstr('{-.3}',5,soutq,lsout)
- end if
-c
-c Put in first note. Call notefq again in case octave changed
-c
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- if (naccg(ngs) .eq. 0) then
- notexq = sq//'zqb0'//noteq(1:lnoten)
- lnote = 5+lnoten
- else
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call accsym(naccg(ngs),acsymq,lacc)
- notexq = sq//'big'//acsymq(1:lacc)//noteq(1:lnoten)
- lnote = 4+lacc+lnoten
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- notexq =notexq(1:lnote)//sq//'zqb0'//noteq(1:lnoten)
- lnote = lnote+5+lnoten
- end if
- call addstr(notexq,lnote,soutq,lsout)
- do 127 ing = ngs+1 , ngs+nng(ig)-1
-c
-c Skip
-c
- ptoff = wheadpt1*emgfac
- if (naccg(ing).gt.0) ptoff = ptoff+wheadpt1*acgfac
- if (isgaft .and. .not.iswaft) aftshft = aftshft+ptoff
- notexq = sq//'off{'
- write(notexq(6:8),'(f3.1)')ptoff
- if (normsp) finalshift = finalshift-ptoff
- call addstr(notexq(1:8)//'pt}',11,soutq,lsout)
- if (ing .eq. ngs+nng(ig)-1) then
-c
-c Terminate beam if needed
-c
- if (upg(ig)) then
- call addstr(sq//'tbu0',5,soutq,lsout)
- else
- call addstr(sq//'tbl0',5,soutq,lsout)
- end if
-c
-c Terminate after slur if needed
-c
- if ((isgaft.or.iswaft) .and. slurg(ig)) then
-c if (iswaft) ndxslur = igetbits(ipl,4,23)
- if (iswaft) ndxslur = igetbits(ipl,5,23)
- call notefq(noteq,lnoten,nolevg(ing),ncm)
- call addstr(sq//'tslur',6,soutq,lsout)
-c
-c Print 11-ndxslur
-cc Print 23-ndxslur
-c
- if (23-ndxslur .lt. 10) then
- call addstr(chax(71-ndxslur)//noteq(1:lnoten),
- * 1+lnoten,soutq,lsout)
- else if (23-ndxslur .lt. 20) then
- call addstr('{2'//chax(61-ndxslur)//'}'
- * //noteq(1:lnoten),4+lnoten,soutq,lsout)
- else
- call addstr('{1'//chax(51-ndxslur)//'}'
- * //noteq(1:lnoten),4+lnoten,soutq,lsout)
- end if
-c
-c Stop slur terminator after exit from this subroutine
-c
- listslur = ibclr(listslur,ndxslur)
- slurg(ig) = .false.
- end if
- end if
-c
-c Accidental if needed
-c
- if (naccg(ing).gt.0) then
- call notefq(noteq,lnoten,nolevg(ing),ncm)
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call accsym(naccg(ing),acsymq,lacc)
- call addstr(sq//'big'//acsymq(1:lacc)
- * //noteq(1:lnoten),4+lacc+lnoten,soutq,lsout)
- end if
-c
-c Put in the (beamed) grace note
-c
- call notefq(noteq,lnoten,nolevg(ing),ncm)
- call addstr(sq//'zqb0'//noteq(1:lnoten),5+lnoten,
- * soutq,lsout)
-127 continue
-c
-c Terminate the grace
-c
-c notexq = sq//'normalnotesize'//sq//'off{'
-c lnote = 20
-c notexq = '}'//sq//'off{'
-c lnote = 6
- notexq = sq//'off{'
- lnote = 5
- ptoff = wheadpt*emgfac
- if (iand(nacc,3).gt.0 .and. .not.btest(nacc,17))
- * ptoff = ptoff+wheadpt*accfac
- if (isgaft .and. .not.iswaft) then
- notexq = notexq(1:5)//'-'
- lnote = 6
- ptoff = aftshft
- end if
- if (normsp) ptoff = finalshift
- if (ptoff .lt. 9.95) then
- write(notexq(lnote+1:lnote+3),'(f3.1)')ptoff
- lnote = lnote+3
- else if (ptoff .lt. 99.95) then
- write(notexq(lnote+1:lnote+4),'(f4.1)')ptoff
- lnote = lnote+4
- else
- write(notexq(lnote+1:lnote+5),'(f5.1)')ptoff
- lnote = lnote+5
- end if
- call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout)
- if (isgaft.and..not.iswaft) call addstr(sq//'sk',3,soutq,lsout)
- call addstr(sq//'resetsize',10,soutq,lsout)
- end if
- return
- end
- subroutine dopsslur(nolev,isdat1,isdat2,isdat3,isdat4,nsdat,ip,
- * iv,kv,nv,beamon,ncm,soutq,lsout,ulq,islur,
- * ipl,iornq,islhgt,tno,nacc)
-c
-c Called once per main note.
-c 12 May 2002 Create this subroutine to isolate postscript slurs/ties.
-c Always set \Nosluradjust\Notieadjust
-c
- parameter (nm=24,mv=24576)
- integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202)
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- character*1 ulq,slurudq,udfq,udqq,chax
- character*79 notexq
- character*8 noteq
- character*80 soutq
- logical upslur,beamon,btest,stemup,iscrd,
- * settie,fontslur,pstie,WrotePsslurDefaults
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- integer*2 mmidi,iinsiv
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
-c 130316
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
-c
-c Bits in isdat1:
-c 13-17 iv
-c 3-10 ip
-c 11 start/stop switch
-c 12 kv-1
-c 19-25 ichar(code$)
-c 26 force direction?
-
-c 27 forced dir'n = up if on, set in sslur; also
-c final direction, set in doslur when beam is started, used on term.
-c 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term.
-c 18 int(ndxslur/16), ditto. So this allows ndxslur>15.
-c 2 stem slur flag
-c 1 flag for "x" slur (voice-independent)
-c
-c Bits in isdat2
-c 0 Chord switch. Not set on main note.
-c 1-2 left/right notehead shift. Set only for chord note.
-c 3 tie positioning
-c 4 dotted flag
-c 6-11 voff1 1-63 => -31...+31
-c 12-18 hoff1 1-127 => -6.3...+6.3
-c 19-25 nolev
-c 26 \sluradjust (p+s)
-c 27 \nosluradjust (p-s)
-c 28 \tieadjust (p+t)
-c 29 \notieadjust (p-t)
-c
-c Bits in isdat3: Only used for slur endings
-c 0 set if midslur (at least one argument)
-c 1 set if curve (2 more args)
-c 2-7 32+first arg (height correction) (1st arg may be negative)
-c 8-10 second arg (initial slope)
-c 11-13 third arg (closing slope)
-c 14-21 tie level for use in LineBreakTies
-c 22-29 ncm for use in LineBreakTies
-c
-c Bits in isdat4 Only used for linebreak slurs
-c 0-5 Linebreak seg 1 voff 1-63 => -31...+31
-c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3
-c 16-21 Linebreak seg 2 voff 1-63 => -31...+31
-c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3
-c
-c In listslur bit ib is on if slur index ib is in use, ib=0-13.
-c ndxslur = slur index
-c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note,
-c s-slur is blank (idcode=32), t-slur is idcode=1.
-c ivoff is user-defined shift or shift due to . or _ , or chord adjustment.
-c Ivoff will be set for ./_ only if no user-defined shift is specified.
-c If highest note has upslur, save slur height in islhgt in case
-c ornament must be moved.
-c
- islhgt = 0
- if (beamon) then
- stemup = ulq .eq. 'u'
- else if (nvmx(iv) .eq. 2) then
- if (.not.btest(islur,30)) then
-c
-c Single note, 2 lines of music, stem direction not forced
-c
- stemup = ivx .gt. nv
- else
- stemup = btest(islur,17)
- end if
- else
- stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u'
- end if
- iscrd = btest(ipl,10)
- if (ismidi) then
- settie = .false.
- dbltie = .false.
- end if
- do 1 isdat = 1 , nsdat
- isdata = isdat1(isdat)
- if (iv .eq. igetbits(isdata,5,13) .and.
- * ip .eq. igetbits(isdata,8,3) .and.
-c * kv .eq. igetbits(isdata,1,12)+1) then
- * (kv .eq. igetbits(isdata,1,12)+1 .or.
- * btest(isdata,1))) then
-c
-c Since iv and kv match, ivx will be correct
-c
- idcode = igetbits(isdata,7,19)
- ivoff = igetbits(isdat2(isdat),6,6)-32
- ihoff = igetbits(isdat2(isdat),7,12)-64
- iupdn = 0
- slurudq = 'd'
- nolevs = igetbits(isdat2(isdat),7,19)
- pstie = btest(isdat2(isdat),3) .or. idcode.eq.1
- if (btest(isdata,11)) then
-c
-c Turnon
-c Get slur direction
-c
- if (btest(isdata,26)) then
-c
-c Force slur direction
-c
- if (btest(isdata,27)) slurudq = 'u'
- else if (nvmx(iv) .eq. 1) then
-c
-c Only one voice per line
-c
- if (.not.beamon) then
-c
-c Separate note.
-c
- slurudq = udfq(nolev,ncm)
- else
-c
-c In a beam
-c
- if (ulq .ne. 'u') slurudq = 'u'
- end if
- if (iscrd) then
- if (nolevs .gt. ncm) then
- slurudq = 'u'
- else
- slurudq = 'd'
- end if
- end if
- else
-c
-c Two voices per line. Get default
-c
- if (ivx .gt. nv) slurudq = 'u'
-c
-c Upper voice of the two, so up slur
-c
- end if
- if (btest(isdata,2)) then
-c
-c ADjust for stem slur. ASSUME this is the ONLY pos'n adjustment.
-c
- if (stemup) then
- slurudq = 'u'
- ivoff = ivoff+4
- else
- slurudq = 'd'
- ivoff = ivoff-4
- end if
- end if
-c
-c Set level for slur starting on rest
-c
- if (nolevs.eq.0 .or. nolevs.gt.60) then
- if (slurudq .eq. 'u') then
- nolevs = ncm+2
- else
- nolevs = ncm-2
- end if
- end if
-c
-c Save up/down-ness for use at termination
-c
- if (slurudq .eq. 'u') isdata = ibset(isdata,27)
-c
-c End of section for setting slur direction, still in "Turnon" if-block.
-c
- if (btest(iornq,11).or.btest(iornq,12)) then
-c
-c Raise or lower slur by one unit provided . or _ is on same side as slur
-c
- ivoffinc = 0
- if ((stemup .and. slurudq.eq.'d') .or.
- * (.not.stemup .and. slurudq.eq.'u')) then
-c
-c Must move the slur for _ or .
-c
- if (stemup) then
- ivoffinc = -1
- else
- ivoffinc = 1
- end if
- if (((stemup .and. nolev.ge.ncm-2) .or.
- * (.not.stemup .and. nolev.le.ncm+2)) .and.
- * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
- ivoff = ivoff+ivoffinc
- end if
- end if
- if (listslur .eq. 16777215) then
- print*
- print*,'You1 defined the twentyfifth slur, one too many!'
- write(15,'(/,a)')
- * 'You defined the twentyfifth slur, one too many!'
- call stop1()
- end if
-c
-c Get index of next slur not in use, starting from 12 down
-c
- ndxslur = log2(16777215-listslur)
-c
-c Record slur index
-c
- listslur = ibset(listslur,ndxslur)
-c
-c Save for use on termination
-c
-c call setbits(isdata,4,28,ndxslur)
-c 080531 Allow >16 slurs
- call setbits(isdata,4,28,mod(ndxslur,16))
- call setbits(isdata,1,18,ndxslur/16)
-c
-c Shift for stem?
-c
- if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) then
- if (.not.pstie) then
- ihoff = ihoff+8
- else
- ihoff = ihoff+2
- end if
- end if
- if (iscrd) then
-c
-c Additional horiz shifts for h-shifted noteheads?
-c
- if (btest(isdat2(isdat),1)) then
-c
-c Slur start on left-shifted chord notehead. ASSUME downstem.
-c
- if (nolevs.eq.minlev .and. slurudq.eq.'d') then
- ihoff = ihoff-2
- else
- ihoff = ihoff-10
- end if
- else if (btest(isdat2(isdat),2)) then
-c
-c Right shifted chord notehead. ASSUME upstem.
-c
- if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
- ihoff = ihoff+2
- else
- ihoff = ihoff+10
- end if
- end if
- end if
- notexq = chax(92)
- lnote = 1
-c
-c Check for local adjustment default changes
-c
- if (btest(isdat2(isdat),26)) then
- notexq = chax(92)//'sluradjust'//chax(92)
- lnote = 12
- else if (btest(isdat2(isdat),27)) then
- notexq = chax(92)//'nosluradjust'//chax(92)
- lnote = 14
- else if (btest(isdat2(isdat),28)) then
- notexq = chax(92)//'tieadjust'//chax(92)
- lnote = 11
- else if (btest(isdat2(isdat),29)) then
- notexq = chax(92)//'notieadjust'//chax(92)
- lnote = 13
- end if
- if (ihoff .eq. 0) then
-c
-c Write stuff for non-shifted start
-c
- notexq = notexq(1:lnote)//'islur'//slurudq
- lnote = lnote+6
- else
- notexq = notexq(1:lnote)//'is'//slurudq
- lnote = lnote+3
- end if
-c
-c Prepend postscript tie switch
-c
- if (pstie) then
- notexq = chax(92)//'tieforis'//slurudq//notexq(1:lnote)
- lnote = lnote+10
- end if
- if (btest(isdat2(isdat),4)) then
-c
-c Dotted slur
-c
-c noteq = notexq
-c notexq = chax(92)//'dotted'//noteq
- notexq = chax(92)//'dotted'//notexq(1:lnote)
- lnote = lnote+7
- end if
-c
-c Add slur index to string
-c Print 23-ndxslur
-c
- if (23-ndxslur .lt. 10) then
-c
-c 5/25/08 Allow 24 slurs
-c
- notexq = notexq(1:lnote)//chax(71-ndxslur)
- lnote = lnote+1
- else if (23-ndxslur .lt. 20) then
- notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = lnote+4
- end if
-c
-c Add note name to string
-c
- islhgt = nolevs+iupdn+ivoff
- call notefq(noteq,lnoten,islhgt,ncm)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
-c
-c Store height and staff mid level for use with LineBreakTies
-c
- call setbits(isdat3(isdat),8,14,islhgt)
- call setbits(isdat3(isdat),8,22,ncm)
-c
-c Save height (for ornament and barnobox interference) if topmost slur is up
-c
- if (slurudq.eq.'u' .and.
- * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
- islhgt = nolevs+iupdn+ivoff
-c
-c Save height & idcode if top voice and slur start
-c
- if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then
- is1n1 = islhgt
- is2n1 = idcode
- end if
- end if
- if (ihoff .ne. 0.) then
- shift = ihoff*0.1
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- lform = lfmt1(shift)
- write(notexq(lnote+1:lnote+lform),'(f'//
- * chax(48+lform)//'.1)') shift
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq,lnote,soutq,lsout)
-c
-c Zero out ip1 to avoid problems if slur goes to next input blk.
-c
- call setbits(isdata,8,3,0)
-c
-c Set slur-on data for midi. Only treat null-index slurs and ps ties for now.
-c
- if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then
-c levson(midchan(iv,kv)) = nolevs
-c 130316
- levson(midchan(iv,kv)) = nolevs+miditran(instno(iv))
- if (settie) dbltie = .true.
-c
-c Only way settie=T is if we just set a tie ending. So there's also a slur
-c start here, so set a flag telling addmidi not to zero out levson
-c
- end if
- else
-c
-c Slur is ending. Back thru list to find starting slur
-c
- do 3 j = isdat-1 , 1 , -1
- if (iv.eq.igetbits(isdat1(j),5,13) .and.
-c * kv.eq.igetbits(isdat1(j),1,12)+1) then
- * (kv.eq.igetbits(isdat1(j),1,12)+1
- * .or. btest(isdat1(j),1))) then
- if (idcode .eq. igetbits(isdat1(j),7,19)) then
- ndxslur = igetbits(isdat1(j),4,28)
-c
-c 080531 Allow >16 slurs
-c
- * +16*igetbits(isdat1(j),1,18)
- if (btest(isdat1(j),27)) slurudq = 'u'
- go to 4
- end if
- end if
-3 continue
- print*,'Bad place in doslur'
- call stop1()
-4 continue
-c
-c Bugfix 070901 for slur ending on rest in 2-voice staff
-c
- if (nolevs.le.2 .or. nolevs.gt.60) then
-c
-c Ending is on a rest, reset nolevs to default starting height
-c
- nolevs = igetbits(isdat2(j),7,19)
- end if
- if (btest(isdat3(isdat),0) .or. btest(isdat3(j),0)) then
-c
-c Deal with \curve or \midslur. isdat is ending, j is start.
-c
- if (btest(isdat3(isdat),0)) then
- imid = igetbits(isdat3(isdat),6,2)-32
- else
- imid = igetbits(isdat3(j),6,2)-32
- end if
-c
-c Postscript slurs, and \midslur adjustment is needed. Invoke macro
-c (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping:
-c Abs(imid) Postscript slur type
-c 1 f
-c 2-3 default
-c 4 h
-c 5 H
-c 6+ HH
-c
- call addstr(chax(92)//'psforts'//
- * chax(48+min(abs(imid),6)),9,soutq,lsout)
- end if
- if (btest(isdata,2)) then
-c
-c ADjust for stem slur.
-c
- if (stemup) then
- slurudq = 'u'
- ivoff = ivoff+4
- else
- slurudq = 'd'
- ivoff = ivoff-4
- end if
- end if
-c
-c Shift slur ending for stem on any note?
-c
- if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) then
- if (.not.pstie) then
- ihoff = ihoff-8
- else
- ihoff = ihoff-3
- end if
- end if
- if (iscrd) then
-c
-c Shift termination for shifted notehead?
-c
- if (btest(isdat2(isdat),1)) then
-c
-c Left-shifted chord notehead. ASSUME downstem.
-c
- if (nolevs.eq.minlev .and. slurudq.eq.'d') then
- ihoff = ihoff-2
- else
- ihoff = ihoff-10
- end if
- else if (btest(isdat2(isdat),2)) then
-c
-c Right shifted chord notehead. ASSUME upstem.
-c
- if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
- ihoff = ihoff+2
- else
- ihoff = ihoff+10
- end if
- end if
- end if
- if (ihoff .eq. 0) then
- notexq = chax(92)//'tslur'
- lnote = 6
- else
-c
-c Shift needed
-c
- notexq = chax(92)//'ts'
- lnote = 3
- end if
-c
-c Switch to postscript tie
-c
- if (pstie) then
- notexq = chax(92)//'tieforts'//notexq(1:lnote)
- lnote = lnote+9
- end if
-c
-c Print 13-ndxslur
-c 5/25/08 Allow 14 slurs
-c
- if (23-ndxslur .lt. 10) then
- notexq = notexq(1:lnote)//chax(71-ndxslur)
- lnote = lnote+1
- else if (23-ndxslur .lt. 20) then
- notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = lnote+4
- end if
- if (btest(iornq,11).or.btest(iornq,12)) then
-c
-c Raise or lower slur by one unit provided . or _ is on same side as slur
-c
- ivoffinc = 0
- if ((stemup .and. slurudq.eq.'d') .or.
- * (.not.stemup .and. slurudq.eq.'u')) then
- if (stemup) then
- ivoffinc = -1
- else
- ivoffinc = 1
- end if
- if (((stemup .and. nolev.ge.ncm-2) .or.
- * (.not.stemup .and. nolev.le.ncm+2)) .and.
- * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
- end if
- ivoff = ivoff+ivoffinc
- end if
- call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
- if (slurudq.eq.'u' .and.
- * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
- islhgt = nolevs+iupdn+ivoff
-c
-c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno.
-c
- if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then
- if (idcode .eq. is2n1) is1n1=0
- end if
- end if
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (ihoff .ne. 0) then
- shift = ihoff*0.1
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- lform = lfmt1(shift)
- write(notexq(lnote+1:lnote+lform),
- * '(f'//chax(48+lform)//'.1)')shift
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq,lnote,soutq,lsout)
-c
-c Clear the bit from list of slurs in use
-c
- listslur = ibclr(listslur,ndxslur)
-c
-c Zero out the entire strings for start and stop
-c
- isdata = 0
- isdat2(isdat) = 0
- isdat3(isdat) = 0
- isdat4(isdat) = 0
- isdat1(j) = 0
- isdat2(j) = 0
- isdat3(j) = 0
- isdat4(j) = 0
-c
-c Set midi info for slur ending
-c
- if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then
- icm = midchan(iv,kv)
- if (slmon(icm)) then
- if (nolevs+miditran(instno(iv)).eq.levson(icm) .and.
- * iand(7,nacc).eq.0) then
-c
-c There is a tie here. NB!!! assumed no accidental on 2nd member of tie.
-c
- levsoff(icm) = nolevs+miditran(instno(iv))
- settie = .true.
- else
- levsoff(icm) = 0
- levson(icm) = 0
- slmon(icm) = .false.
- end if
- end if
- end if
- end if
- isdat1(isdat) = isdata
- end if
-1 continue
-c
-c Clear and collapse the slur data list
-c
- numdrop = 0
- do 2 isdat = 1 , nsdat
- if (isdat1(isdat) .eq. 0) then
- numdrop = numdrop+1
- else if (numdrop .gt. 0) then
- isdat1(isdat-numdrop) = isdat1(isdat)
- isdat2(isdat-numdrop) = isdat2(isdat)
- isdat3(isdat-numdrop) = isdat3(isdat)
- isdat4(isdat-numdrop) = isdat4(isdat)
- isdat1(isdat) = 0
- isdat2(isdat) = 0
- isdat3(isdat) = 0
- isdat4(isdat) = 0
- end if
-2 continue
- nsdat = nsdat-numdrop
-c call report(nsdat,isdat1,isdat2)
- return
- end
- subroutine doslur(nolev,isdat1,isdat2,isdat3,nsdat,ip,iv,kv,nv,
- * beamon,ncm,soutq,lsout,ulq,islur,ipl,iornq,islhgt,tno,nacc)
-c
-c Called once per main note. (5/26/02) for non-ps slurs only
-c
- parameter (nm=24,mv=24576)
- integer*4 isdat1(202),isdat2(202),isdat3(202)
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- character*1 ulq,slurudq,udfq,udqq,chax
- character*79 notexq
- character*8 noteq
- character*80 soutq
- logical upslur,beamon,btest,stemup,iscrd,sfound,tfound,tmove,
- * settie,fontslur,WrotePsslurDefaults
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- integer*2 mmidi,iinsiv
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
-c 130316
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
-c
-c Bits in isdat1:
-c 13-17 iv
-c 3-10 ip
-c 11 start/stop switch
-c 12 kv-1
-c 19-25 ichar(code$)
-c 26 force direction?
-c 27 forced dir'n = up if on, set in sslur; also
-c final direction, set in doslur when beam is started, used on term.
-c 28-31 ndxslur, set in doslur when beam is started, used on term.
-c
-c Bits in isdat2
-c 0 Chord switch. Not set on main note.
-c 1-2 left/right notehead shift. Set only for chord note.
-c 3 tie positioning
-c 4 dotted flag
-c 6-11 voff1 1-63 => -31...+31
-c 12-18 hoff1 1-127 => -6.3...+6.3
-c 19-25 nolev
-c
-c Bits in isdat3: Only used for slur endings
-c 0 set if midslur (at least one argument)
-c 1 set if curve (2 more args)
-c 2-7 32+first arg (height correction) (1st arg may be negative)
-c 8-10 second arg (initial slope)
-c 11-13 third arg (closing slope)
-c
-c In listslur bit ib is on if slur index ib is in use, ib=0-23.
-c ndxslur = slur index
-c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note,
-c s-slur is blank (idcode=32), t-slur is idcode=1.
-c ivoff is user-defined shift or shift due to . or _ , or chord adjustment.
-c Ivoff will be set for ./_ only if no user-defined shift is specified.
-c If highest note has upslur, save slur height in islhgt in case
-c ornament must be moved.
-c
- islhgt = 0
- if (beamon) then
- stemup = ulq .eq. 'u'
- else if (nvmx(iv) .eq. 2) then
- if (.not.btest(islur,30)) then
-c
-c Single note, 2 lines of music, stem direction not forced
-c
- stemup = ivx .gt. nv
- else
- stemup = btest(islur,17)
- end if
- else
- stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u'
- end if
- iscrd = btest(ipl,10)
- if (btest(islur,1)) then
-c
-c 't'-slur (idcode=1) somewhere on this note. Find it, check height against
-c 's'-slur (idcode=32)
-c
- sfound = .false.
- tfound = .false.
- tmove = .false.
- do 5 isdat = 1 , nsdat
- if (iv .eq. igetbits(isdat1(isdat),5,13) .and.
- * ip .eq. igetbits(isdat1(isdat),8,3) .and.
- * kv .eq. igetbits(isdat1(isdat),1,12)+1) then
- if (.not.tfound) then
- tfound = igetbits(isdat1(isdat),7,19).eq.1
- if (tfound) then
- nolevt = igetbits(isdat2(isdat),7,19)
- isdatt = isdat
- if (sfound) go to 6
- end if
- end if
- if (.not.sfound) then
- sfound = igetbits(isdat1(isdat),7,19).eq.32
- if (sfound) then
- nolevs = igetbits(isdat2(isdat),7,19)
- isdats = isdat
- if (tfound) go to 6
- end if
- end if
- end if
-5 continue
-c
-c Will come thru here if there is a t with no s, so comment out the following
-c print*,'Did not find s+t-slurs in doslur'
-c
-6 continue
- if (sfound .and. tfound)
- * tmove = nolevs.eq.nolevt .and.
-c
-c Check if 2 starts or two stops
-c
- * ((btest(isdat1(isdats),11).and.btest(isdat1(isdatt),11)) .or.
- * (.not.btest(isdat1(isdats),11).and.
- * .not.btest(isdat1(isdatt),11)) )
-c
-c This is a flag for later changing slur level, after we know slur dir'n.
-c
- end if
- if (ismidi) then
- settie = .false.
- dbltie = .false.
- end if
- do 1 isdat = 1 , nsdat
- isdata = isdat1(isdat)
- if (iv .eq. igetbits(isdata,5,13) .and.
- * ip .eq. igetbits(isdata,8,3) .and.
- * kv .eq. igetbits(isdata,1,12)+1) then
-c
-c Since iv and kv match, ivx will be correct
-c
- idcode = igetbits(isdata,7,19)
- ivoff = igetbits(isdat2(isdat),6,6)-32
- ihoff = igetbits(isdat2(isdat),7,12)-64
- iupdn = 0
- slurudq = 'd'
- nolevs = igetbits(isdat2(isdat),7,19)
- if (btest(isdata,11)) then
-c
-c Turnon,
-c
- if (nolevs.eq.0 .or. nolevs.gt.60) then
-c
-c Note was a rest, cannot start slur on rest.
-c
- print*
- call printl('Cannot start slur on a rest')
- call stop1()
- end if
-c
-c Get slur direction
-c
- if (btest(isdata,26)) then
-c
-c Force slur direction
-c
- if (btest(isdata,27)) slurudq = 'u'
- else if (nvmx(iv) .eq. 1) then
-c
-c Only one voice per line
-c
- if (.not.beamon) then
-c
-c Separate note.
-c
- slurudq = udfq(nolev,ncm)
- else
-c
-c In a beam
-c
- if (ulq .ne. 'u') slurudq = 'u'
- end if
- if (iscrd) then
- if (nolevs .gt. ncm) then
- slurudq = 'u'
- else
- slurudq = 'd'
- end if
- end if
- else
-c
-c Two voices per line. Get default
-c
- if (ivx .gt. nv) slurudq = 'u'
-c
-c Upper voice of the two, so up slur
-c
- end if
-c
-c Save up/down-ness for use at termination
-c
- if (slurudq .eq. 'u') isdata = ibset(isdata,27)
-c
-c End of section for setting slur direction, still in "Turnon" if-block.
-c
- if (idcode.eq.1 .and. tmove) then
- iupdn = 1
- if (slurudq .eq. 'd') iupdn = -1
- end if
- if (btest(iornq,11).or.btest(iornq,12)) then
-c
-c Raise or lower slur by one unit provided . or _ is on same side as slur
-c
- ivoffinc = 0
- if ((stemup .and. slurudq.eq.'d') .or.
- * (.not.stemup .and. slurudq.eq.'u')) then
-c
-c Must move the slur for _ or .
-c
- if (stemup) then
- ivoffinc = -1
- else
- ivoffinc = 1
- end if
- if (((stemup .and. nolev.ge.ncm-2) .or.
- * (.not.stemup .and. nolev.le.ncm+2)) .and.
- * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
- ivoff = ivoff+ivoffinc
- end if
- end if
- if (listslur .eq. 16777215) then
- print*
- print*,'You1 defined the twenty-fifth slur, one too many!'
- write(15,'(/,a)')
- * 'You2 defined the twenty-fifth slur, one too many!'
- call stop1()
- end if
-c
-c Get index of next slur not in use, starting from ? down
-c
- ndxslur = log2(16777215-listslur)
-c
-c Record slur index
-c
- listslur = ibset(listslur,ndxslur)
-c
-c Save for use on termination
-c
-c call setbits(isdata,4,28,ndxslur)
-c 080531 Allow >16 slurs
- call setbits(isdata,4,28,mod(ndxslur,16))
- call setbits(isdata,1,18,ndxslur/16)
-c
-c Shift for stem?
-c
- if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.)
- * ihoff = ihoff+8
- if (btest(isdat2(isdat),3)) then
-c
-c Tie spacing, (slur start)
-c
- if (slurudq.eq.'d') then
- ivoff = ivoff+1
- ihoff = ihoff+8
- else if (slurudq.eq.'u') then
- ivoff = ivoff-1
- if (.not.(stemup.and.tno.lt.63.)) ihoff = ihoff+8
-c
-c (already shifted if (stemup.and.tno.gt.63.) and slurudq='u')
-c
- end if
- end if
- if (iscrd) then
-c
-c Additional horiz shifts for h-shifted noteheads?
-c
- if (btest(isdat2(isdat),1)) then
-c
-c Slur start on left-shifted chord notehead. ASSUME downstem.
-c
- if (nolevs.eq.minlev .and. slurudq.eq.'d') then
- ihoff = ihoff-2
- else
- ihoff = ihoff-10
- end if
- else if (btest(isdat2(isdat),2)) then
-c
-c Right shifted chord notehead. ASSUME upstem.
-c
- if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
- ihoff = ihoff+2
- else
- ihoff = ihoff+10
- end if
- end if
- end if
- if (ihoff .eq. 0) then
-c
-c Write stuff for non-shifted start
-c
- notexq = chax(92)//'islur'//slurudq
- lnote = 7
- else
- notexq = chax(92)//'is'//slurudq
- lnote = 4
- end if
- if (btest(isdat2(isdat),4)) then
-c
-c Dotted slur
-c
- noteq(1:8) = notexq
- notexq = chax(92)//'dotted'//noteq
- lnote = lnote+7
- end if
-c
-c Add slur index to string
-cc Print 11-ndxslur
-c Print 23-ndxslur
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c
-c 5/25/08 Allow 24 slurs
-c
-c notexq = notexq(1:lnote)//chax(59-ndxslur)
- notexq = notexq(1:lnote)//chax(71-ndxslur)
- lnote = lnote+1
- else if (23-ndxslur .lt. 20) then
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
- notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = lnote+4
- end if
-c
-c Add note name to string
-c
- call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
-c
-c Save height (for ornament and barnobox interference) if topmost slur is up
-c
- if (slurudq.eq.'u' .and.
- * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
- islhgt = nolevs+iupdn+ivoff
-c
-c Save height & idcode if top voice and slur start
-c
- if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then
- is1n1 = islhgt
- is2n1 = idcode
- end if
- end if
- if (ihoff .ne. 0.) then
- shift = ihoff*0.1
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- lform = lfmt1(shift)
- write(notexq(lnote+1:lnote+lform),'(f'//
- * chax(48+lform)//'.1)') shift
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq,lnote,soutq,lsout)
-c
-c Zero out ip1 to avoid problems if slur goes to next input blk.
-c
- call setbits(isdata,8,3,0)
-c
-c Set slur-on data for midi. Only treat null-index slurs and ps ties for now.
-c
- if (ismidi .and. idcode.eq.32) then
- levson(midchan(iv,kv)) = nolevs+miditran(instno(iv))
- if (settie) dbltie = .true.
-c
-c Only way settie=T is if we just set a tie ending. So there's also a slur
-c start here, so set a flag telling addmidi not to zero out levson
-c
- end if
- else
-c
-c Slur is ending. Back thru list to find starting slur
-c
- do 3 j = isdat-1 , 1 , -1
- if (iv.eq.igetbits(isdat1(j),5,13) .and.
- * kv.eq.igetbits(isdat1(j),1,12)+1) then
- if (idcode .eq. igetbits(isdat1(j),7,19)) then
- ndxslur = igetbits(isdat1(j),4,28)
-c
-c 080531 Allow >16 slurs
-c
- * +16*igetbits(isdat1(j),1,18)
- if (btest(isdat1(j),27)) slurudq = 'u'
- go to 4
- end if
- end if
-3 continue
- print*,'Bad place in doslur'
- call stop1()
-4 continue
- if (nolevs.eq.0 .or. nolevs.gt.60) then
-c
-c Ending is on a rest, reset nolevs to default starting height
-c
- nolevs = igetbits(isdat2(j),7,19)
- end if
- if (btest(isdat3(isdat),0)) then
-c
-c Deal with \curve or \midslur
-c
- imid = igetbits(isdat3(isdat),6,2)-32
-c
-c Remember, only dealing with non-ps slurs
-c
-c Who knows where the following line came from. Removed it 6/30/02 to
-c restore behavior of non-ps slurs to old way
-c if (slurudq .eq. 'd') imid = -imid
-c 3/8/03 added the following
-c
- if (slurudq .eq. 'd') imid = -abs(imid)
-c
- if (btest(isdat3(isdat),1)) then
- notexq = chax(92)//'curve'
- lnote = 6
- else
- notexq = chax(92)//'midslur'
- lnote = 8
- end if
- if (imid.lt.0 .or. imid.gt.9) then
-c
-c Need brackets
-c
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (imid .lt. -9) then
- write(notexq(lnote+1:lnote+3),'(i3)')imid
- lnote = lnote+3
- else if (imid.lt.0 .or. imid.gt.9) then
- write(notexq(lnote+1:lnote+2),'(i2)')imid
- lnote = lnote+2
- else
- write(notexq(lnote+1:lnote+1),'(i1)')imid
- lnote = lnote+1
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- else
-c
-c 1=<imid=<9, no brackets
-c
- notexq = notexq(1:lnote)//char(48+imid)
- lnote = lnote+1
- end if
- if (btest(isdat3(isdat),1)) then
-c
-c \curve; 3 args
-c
- notexq = notexq(1:lnote)
- * //char(48+igetbits(isdat3(isdat),3,8))
- notexq = notexq(1:lnote+1)
- * //char(48+igetbits(isdat3(isdat),3,11))
- lnote = lnote+2
- end if
- call addstr(notexq,lnote,soutq,lsout)
- end if
-c
-c Shift slur ending for stem on any note?
-c
- if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.)
- * ihoff = ihoff-8
- if (btest(isdat2(isdat),3)) then
-c
-c Shift ending for tie spacing
-c
- if (slurudq .eq. 'u') then
- ihoff = ihoff-8
- ivoff = ivoff-1
- else if (slurudq .eq. 'd') then
- ivoff = ivoff+1
- if (stemup.or. tno.gt.63.) ihoff = ihoff-8
- end if
- end if
- if (iscrd) then
-c
-c Shift termination for shifted notehead?
-c
- if (btest(isdat2(isdat),1)) then
-c
-c Left-shifted chord notehead. ASSUME downstem.
-c
- if (nolevs.eq.minlev .and. slurudq.eq.'d') then
- ihoff = ihoff-2
- else
- ihoff = ihoff-10
- end if
- else if (btest(isdat2(isdat),2)) then
-c
-c Right shifted chord notehead. ASSUME upstem.
-c
- if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
- ihoff = ihoff+2
- else
- ihoff = ihoff+10
- end if
- end if
- end if
- if (ihoff .eq. 0) then
- notexq = chax(92)//'tslur'
- lnote = 6
- else
-c
-c Shift needed
-c
- notexq = chax(92)//'ts'
- lnote = 3
- end if
-c
-c Print 23-ndxslur
-c 5/25/08 Allow 14 slurs (???????????)
-c
- if (23-ndxslur .lt. 10) then
- notexq = notexq(1:lnote)//chax(71-ndxslur)
- lnote = lnote+1
- else if (23-ndxslur .lt. 20) then
- notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = lnote+4
- end if
- if (btest(iornq,11).or.btest(iornq,12)) then
-c
-c Raise or lower slur by one unit provided . or _ is on same side as slur
-c
- ivoffinc = 0
- if ((stemup .and. slurudq.eq.'d') .or.
- * (.not.stemup .and. slurudq.eq.'u')) then
- if (stemup) then
- ivoffinc = -1
- else
- ivoffinc = 1
- end if
- if (((stemup .and. nolev.ge.ncm-2) .or.
- * (.not.stemup .and. nolev.le.ncm+2)) .and.
- * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
- end if
- ivoff = ivoff+ivoffinc
- end if
- if (idcode.eq.1 .and. tmove) then
-c
-c t-slur height adjustment
-c
- iupdn = 1
- if (slurudq .eq. 'd') iupdn = -1
- end if
- call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
- if (slurudq.eq.'u' .and.
- * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
- islhgt = nolevs+iupdn+ivoff
-c
-c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno.
-c
- if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then
- if (idcode .eq. is2n1) is1n1=0
- end if
- end if
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (ihoff .ne. 0) then
- shift = ihoff*0.1
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- lform = lfmt1(shift)
- write(notexq(lnote+1:lnote+lform),
- * '(f'//chax(48+lform)//'.1)')shift
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq,lnote,soutq,lsout)
-c
-c Clear the bit from list of slurs in use
-c
- listslur = ibclr(listslur,ndxslur)
-c
-c Zero out the entire strings for start and stop
-c
- isdata = 0
- isdat2(isdat) = 0
- isdat1(j) = 0
- isdat2(j) = 0
- isdat3(isdat) = 0
-c
-c Set midi info for slur ending
-c
- if (ismidi .and. idcode.eq.32) then
- icm = midchan(iv,kv)
- if (slmon(icm)) then
- if (nolevs+miditran(instno(iv)).eq.levson(icm) .and.
- * iand(7,nacc).eq.0) then
-c
-c There is a tie here. NB!!! assumed no accidental on 2nd member of tie.
-c
- levsoff(icm) = nolevs+miditran(instno(iv))
- settie = .true.
- else
- levsoff(icm) = 0
- levson(icm) = 0
- slmon(icm) = .false.
- end if
- end if
- end if
- end if
- isdat1(isdat) = isdata
- end if
-1 continue
-c
-c Clear and collapse the slur data list
-c
- numdrop = 0
- do 2 isdat = 1 , nsdat
- if (isdat1(isdat) .eq. 0) then
- numdrop = numdrop+1
- else if (numdrop .gt. 0) then
- isdat1(isdat-numdrop) = isdat1(isdat)
- isdat2(isdat-numdrop) = isdat2(isdat)
- isdat3(isdat-numdrop) = isdat3(isdat)
- isdat1(isdat) = 0
- isdat2(isdat) = 0
- isdat3(isdat) = 0
- end if
-2 continue
- nsdat = nsdat-numdrop
-c call report(nsdat,isdat1,isdat2)
- return
- end
- subroutine dotmov(updot,rtdot,soutq,lsout,iddot)
-c
-c iddot = 0 for single dot, 1 for double
-c
- character*80 soutq,notexq
- character*1 sq,chax
- sq = chax(92)
- lfmtup = lfmt1(updot)
- lfmtrt = lfmt1(rtdot)
- write(notexq,'(a37,f'//chax(48+lfmtup)//'.1,a2,f'//chax(48+lfmtrt)
- * //'.1,a15)')
- * sq//'makeatletter'//sq//'def'//sq//'C at Point#1#2{'//sq//
- * 'PMXpt{',updot,'}{',rtdot,'}'//chax(48+iddot)//'}'//sq
- * //'makeatother'
-c
-c Example of string just created:
-c \makeatletter\def\C at Point#1#2{\PMXpt{.5}{.5}}\makeatother\
-c
- lnote = 54+lfmtup+lfmtrt
- call addstr(notexq(1:lnote),lnote,soutq,lsout)
- return
- end
- subroutine dotrill(iv,ip,iornq,noteq,lnoten,notexq,lnote)
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- character*1 chax
- character*8 noteq
- character*79 notexq
- logical tronly,btest
- do 1 itr = 1 , ntrill
- if (iv.eq.ivtrill(itr) .and. ip.eq.iptrill(itr)) go to 2
-1 continue
- print*,'Problem in dotrill. Call Dr. Don'
- stop
-2 continue
- tronly = xnsktr(itr) .lt. 0.01
- if (tronly) then
- notexq = chax(92)//'zcharnote'
- lnote = 10
- else if (btest(iornq,7)) then
- notexq = chax(92)//'Trille'
- lnote = 7
- else
- notexq = chax(92)//'trille'
- lnote = 7
- end if
- notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
- lnote = lnote+lnoten+1
-c
-c Write trill duration to nearest tenth of a noteskip
-c
- if (tronly) then
- notexq = notexq(1:lnote)//chax(92)//'it tr}'
- lnote = lnote+7
- return
- end if
- if (xnsktr(itr) .lt. .95) then
- nfmt = 2
- else if (xnsktr(itr) .lt. 9.95) then
- nfmt = 3
- else
- nfmt = 4
- end if
- write(notexq(lnote+1:lnote+nfmt),'(f'//chax(48+nfmt)//'.1)')
- * xnsktr(itr)
- lnote = lnote+nfmt
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- return
- end
- subroutine endslur(stemup,upslur,nolev,iupdn,ndxslur,ivoff,ncm,
- * soutq,lsout,fontslur)
-c
-c Only called to end slur started in dograce.
-c
- logical shift,stemup,upslur,fontslur
- character*80 soutq
- character*79 notexq
- character*8 noteq
- character*1 chax
- shift = .not.stemup .and. .not.upslur
- if (.not.shift) then
-c
-c No shift needed
-c
- notexq = chax(92)//'tslur'
- lnote = 6
- else
-c
-c Shift needed
-c
- notexq = chax(92)//'ts'
- lnote = 3
- end if
-c if (ndxslur .lt. 10) then
-c notexq = notexq(1:lnote)//chax(48+ndxslur)
-c lnote = lnote+1
-c else
-c notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}'
-c lnote = lnote+4
-c end if
-c
-cc Print 11-ndxslur
-c Print 23-ndxslur
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c notexq = notexq(1:lnote)//chax(59-ndxslur)
- notexq = notexq(1:lnote)//chax(71-ndxslur)
- lnote = lnote+1
- else if (23-ndxslur .lt. 20) then
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
- notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = lnote+4
- end if
- call notefq(noteq,lnoten,nolev+iupdn+ivoff,ncm)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (shift) then
- if (fontslur) then
- notexq = notexq(1:lnote)//'{-.6}'
- else
- notexq = notexq(1:lnote)//'{-.8}'
- end if
- lnote = lnote+5
- end if
- call addstr(notexq,lnote,soutq,lsout)
- return
- end
- subroutine errmsg(lineq,iccount,ibarno,msgq)
- parameter(nm=24)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,fbon,issegno,isheadr,isvolt
- character*128 lineq
- character*78 outq
- character*(*) msgq
- character*1 chax
- common /truelinecount/ linewcom(20000)
- if (iccount .le. 78) then
- outq = lineq(1:78)
- iposn = iccount
- else
- outq = '... '//lineq(55:128)
- iposn = iccount-50
- end if
- print*
- ibarnop = ibarno
- if (linesinpmxmod.eq.0 .or.
- * nline .gt. line1pmxmod+linesinpmxmod) then
-c
-c Error is in main .pmx file
-c
-c nlinep = nline-linesinpmxmod
-c Correct for comments not copied into buffer
- nlinep = linewcom(nline)-linesinpmxmod
- else
-c
-c Error is in include file
-c
- ibarnop = 0
- nlinep = nline-line1pmxmod+1
- call printl(
- * 'ERROR in include file named above, description given below')
- end if
- open(19,file='pmxaerr.dat')
- write(19,'(i6)') nlinep
- close(19)
- ndigbn = max(1,int(log10(ibarnop+.1)+1))
- ndignl = int(log10(nlinep+.1)+1)
- lenmsg = index(msgq,'!')-1
-c
-c Split off msgq(..) since UNIX compilers don't allow concat substring!!!
-c
- write(*,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)//
- *',$)')' ERROR in line ',nlinep,', bar ',ibarnop
- write(*,'(1x,a)')msgq(1:lenmsg)
- write(15,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)//
- *',$)')' ERROR in line ',nlinep,', bar ',ibarnop
- write(15,'(a)')msgq(1:lenmsg)
- i10 = iposn/10
- i1 = iposn-10*i10
- write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v'
- write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v'
- print*,outq(1:78)
- write(15,'(a)')' '//outq(1:78)
- write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^'
- write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^'
- return
- end
- subroutine eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk)
-c
-c Get elemskips to previous note. Called only for graces, no xtups involved.
-c
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- real*4 tstart(80),space(80)
- common /comtol/ tol
- itnd = nint(to(in))
- if (ip.eq.1 .or. itnd.eq.itrpt) then
-c
-c Start of bar or after rpt.
-c
- esk = fbar
- return
- else
- esk = 0.
- itprev = itnd-nodur(ivx,ip-1)
- do 1 iib = ib , 1 , -1
- if (tstart(iib) .lt. itprev+tol) then
-c
-c This is the block
-c
- nnsk = nint(float((itnd-itprev))/space(iib))
- esk = esk+nnsk*feon(space(iib))
- return
- else
- nnsk = nint((itnd-tstart(iib))/space(iib))
- esk = esk+nnsk*feon(space(iib))
- itnd = nint(tstart(iib))
- end if
-1 continue
- end if
- print*,'Problem in eskb4. Send files to Dr. Don'
- stop
- end
- function f1eon(time)
- f1eon = sqrt(time/2)
- return
- end
- function feon(time)
- common /comeon/ eonk,ewmxk
- feon = sqrt(time/2)**(1.-eonk)*ewmxk
- return
- end
- subroutine findbeam(ibmrep,numbms,mapfb)
-c
-c Called once per voice per bar, after setting forced beams.
-c
- parameter (nm=24)
- dimension mask(49,3),nummask(3),eqonly(49,3)
-c integer numbms(nm),ipr(48),nip1(0:47),nip2(0:47),mapfb(16),
-c * itr(48),nodue(48)
-c logical short(48),eqonly
- integer numbms(nm),ipr(248),nip1(0:247),nip2(0:247),mapfb(16),
- * itr(248),nodue(248)
- logical short(248),eqonly
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- common /combeam/ ibmtyp
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtol/ tol
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,
- * isfig,btest
- data nip1,nip2 /496*0/
- data nummask / 29 , 49 , 12 /
- data mask
- * / 65535, 4095, 65520, 255, 65280, 63,
- * 252, 16128, 64512, 15, 240, 3840,
- * 61440, 7, 14, 112, 224, 1792,
- * 3584, 28672, 57344, 3, 12, 48,
- * 192, 768, 3072, 12288, 49152, 20*0 ,
- * 16777215, 65535, 16776960, 4095, 65520, 1048320,
- * 16773120, 255, 65280, 16711680, 63, 252,
- * 16128, 64512, 4128768, 16515072, 15, 60,
- * 240, 3840, 15360, 61440, 983040, 3932160,
- * 15728640, 7, 14, 112, 224, 1792,
- * 3584, 28672, 57344, 458752, 917504, 7340032,
- * 14680064, 3, 12, 48, 192, 768,
- * 3072, 12288, 49152, 196608, 786432, 3145728,
- * 12582912,
- * 4095, 255, 4080, 15, 240, 3840,
- * 3, 12, 48, 192, 768, 3072,
- * 37*0 /
- data eqonly /3*.true.,46*.false.,7*.true.,91*.false./
- ip = 0
- nreal = 0
- itnow = 0
-1 continue
- ip = ip+1
- if (ip .gt. nn(ivx)) go to 9
-11 if (nodur(ivx,ip).eq.0) then
-c
-c Ignore all xtup notes except the last, the one with nodur > 0 .
-c Xtups are irrelevant here since they are already all in forced beams.
-c Will update itnow by nodur at the END of this loop
-c
- ip = ip+1
- go to 11
- end if
- nreal = nreal+1
- nodue(nreal) = nodur(ivx,ip)
- short(nreal) = nodue(nreal).lt.16 .and.
- * .not.btest(irest(ivx,ip),0)
-c
-c Rule out notes that have 'alone'-flag set
-c
- * .and..not.btest(islur(ivx,ip),18)
- ipr(nreal) = ip
- itr(nreal) = itnow
- if (nodue(nreal) .eq. 1) then
-c
-c 64th gap
-c
- if (mod(itnow,2) .eq. 0) then
-c
-c Start of 32nd gap, lump with following note
-c
- ip = ip+1
- nodue(nreal) = 1+nodur(ivx,ip)
- itnow = itnow+nodue(nreal)
- else
-c
-c End of 32nd gap, lump with preceeding note
-c
- nreal = nreal-1
- nodue(nreal) = 1+nodue(nreal)
- itnow = itnow+1
- end if
- else
- itnow = itnow+nodur(ivx,ip)
- end if
- go to 1
-9 continue
- ir1 = 1
- itseg = lenbar/ibmrep
- do 13 irep = 1 , ibmrep
-c
-c Set bitmaps for all shorts neighbored by a short. Each bit represents a
-c span of 32nd note. maps, mapm, mape record start, full duration, and end
-c of consecutive span of beamable (<1/4) notes.
-c
- maps = 0
- mapm = 0
- mape = 0
- itend = itseg*irep
- itoff = itend-itseg
- do 2 ir = ir1 , nreal
- it2 = itr(ir)+nodue(ir)-2
- if (it2 .ge. itend) then
- ir1 = ir
- go to 14
- end if
-c if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal
- if (short(ir).and.((ir.gt.1.and.short(max(ir-1,1))).or.
- * (ir.lt.nreal.and.short(ir+1)))) then
- ib1 = (itr(ir)-itoff)/2
- ib2 = (it2-itoff)/2
- if (max(ib1,ib2).gt.47 .or. ir.gt.48 .or.
- * min(ib1,ib2).lt.0) return
-c
-c Must have an odd number obe beats in a long bar. Auto-beam won't work
-c
- nip1(ib1) = ipr(ir)
- nip2(ib2) = ipr(ir)
-c
-c nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip
-c
- maps = ibset(maps,ib1)
- mape = ibset(mape,ib2)
- do 3 ib = ib1 , ib2
- mapm = ibset(mapm,ib)
-3 continue
- end if
-2 continue
-14 continue
- if (mapm .eq. 0) go to 13
-c
-c Zero out bits from forced beams
-c
- maps = iand(maps,not(mapfb(irep)))
- mapm = iand(mapm,not(mapfb(irep)))
- mape = iand(mape,not(mapfb(irep)))
-c
-c Compare map with template.
-c
- do 4 it = 1 , nummask(ibmtyp)
- masknow = mask(it,ibmtyp)
- if (iand(masknow,mapm) .eq. masknow) then
-c
-c Find least significant bit in the mask to check start time
-c
- mtemp = masknow
- maskm = masknow
- do 5 is1 = 0 , 47
- if (iand(1,mtemp) .eq. 1) go to 6
- mtemp = ishft(mtemp,-1)
-5 continue
-6 continue
- if (iand(ishft(1,is1),maps) .eq. 0) go to 4
-c
-c is1 is the bit where the beam starts. Continue shifting to
-c find most significant bit in the mask to check ending time
-c
- do 7 is2 = is1 , 47
- mtemp = ishft(mtemp,-1)
- if (iand(1,not(mtemp)) .eq. 1) go to 8
-7 continue
-8 continue
-c
-c is2 is now the bit on which the beam ends.
-c
- if (iand(ishft(1,is2),mape) .eq. 0) go to 4
-c
-c Did we pick out a single note from the middle of a longer sequence?
-c
- if (nip1(is1) .eq. nip2(is2)) go to 4
-c
-c We almost have a beam. Check equality of notes if needed.
-c
- if (eqonly(it,ibmtyp)) then
- do 10 ip = nip1(is1) , nip2(is2)
- if (nodur(ivx,ip) .ne. 8) then
-c
-c There is a non-1/8th note in this beam. Exit if not 2 quarters
-c
- if (is2-is1 .ne. 15) go to 4
-c
-c Beam is 2 quarters long. Check if can split in half.
-c
- ithalf = 0
- do 20 iip = nip1(is1) , nip2(is2)
- ithalf = ithalf+nodur(ivx,iip)
- if (ithalf .gt. 16) go to 4
- if (ithalf .eq. 16) go to 21
-20 continue
- print*,'Problem in findbeam, please call Dr. Don'
- go to 4
-21 continue
-c
-c Otherwise, split in half by keeping only the first half. Other half will
-c be picked up later, assuming masks are listed longest first.
-c
- is2 = is1+7
-c
-c Reset maskm (since only used part of mask), used later to zero out
-c bits that contain beams
-c
- maskm = 0
- do 15 is = is1 , is2
- maskm = ibset(maskm,is)
-15 continue
- go to 16
- end if
-10 continue
- end if
-16 continue
-c
-c This is a beam. If last "effective" ends on odd 64th, add 1 more
-c
-c if (abs(mod(to(iand(255,ipl(ivx,nip2(is2))))
-c * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then
- if (abs(amod(to(ipl2(ivx,nip2(is2)))
- * +nodur(ivx,nip2(is2))+.5*tol,2.)) .gt. tol) then
- nip2(is2) = nip2(is2)+1
- end if
- numbms(ivx) = numbms(ivx)+1
- numnew = numbms(ivx)
- call logbeam(numnew,nip1(is1),nip2(is2))
-c
-c Zero out the appropriate bits so these notes don't get used again
-c
- mapm = iand(mapm,not(maskm))
- if (mapm.eq.0) go to 13
- maps = iand(maps,not(maskm))
- mape = iand(mape,not(maskm))
- end if
-4 continue
-13 continue
- return
- end
- subroutine findeonk(nptr1,nptr2,wovera,xelsk,dtmin,dtmax,eonk0)
- parameter (nkb=3999,maxblks=9600)
-c
-c Compute an exponent eonk for use in the "flattened" formula for elemskips
-c vs time. We must solve the eqution f = 0. Initial quess is eonk0.
-c
-c logical gotclef
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
-c * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- * ibaroff,udsp(nkb),wheadpt,sqzb(maxblks)
- common /comtol/ tol
- common /comeon/ eonk,ewmxk
- eonk = eonk0
- niter = 0
-1 continue
- ewmxk = f1eon(dtmax)**eonk
- niter = niter+1
- esum = 0.
- desum = 0.
- do 2 iptr = nptr1 , nptr2
- targ = durb(iptr)/sqzb(iptr)
- esum = esum+nnpd(iptr)*sqzb(iptr)*feon(targ)
- detarg = sqrt(targ/2*(dtmax/targ)**eonk)*alog(dtmax/targ)
- desum = desum+nnpd(iptr)*sqzb(iptr)*detarg
-2 continue
- f = wovera*feon(dtmin)-xelsk-esum
- fp = wovera*sqrt(dtmin/2*(dtmax/dtmin)**eonk)*alog(dtmax/dtmin)
- * -desum
- if (abs(fp).lt.tol .or. abs(eonk-.5).gt..5 .or. niter.gt.100) then
- call printl(
- * 'Error in findeonk. Please send source to Dr. Don')
- eonk = 0.
- ewmxk = 1.
- return
- end if
- dsoln = -f/fp
- if (abs(dsoln) .lt. .1*tol) return
-c
-c Not converged yet, try again
-c
- eonk = eonk+dsoln
- go to 1
- end
- function fnote(nodur,ivx,ip,nacc)
-c
-c This return the real duration of a note
-c
- parameter (nm=24)
- integer*4 nodur(nm,200),nacc(nm,200)
- logical btest
- ipback = ip
- if (nodur(ivx,ip) .gt. 0) then
- if (ip .gt. 1) then
-c
-c Check if this is last note of xtup
-c
- if (nodur(ivx,ip-1).eq.0) then
- ipback = ip-1
- go to 2
- end if
- end if
- fnote = nodur(ivx,ip)
- return
- end if
-2 continue
-c
-c Count back to prior non zero note. Start at ip to avoid neg index if ip=1.
-c Count how many doubled xtups notes there are from ip-1 to first note.
-c
- ndoub = 0
- do 1 ip1m1 = ipback , 1 , -1
- if (nodur(ivx,ip1m1) .gt. 0) go to 4
- if (ip1m1.lt.ip .and. btest(nacc(ivx,ip1m1),18)) ndoub=ndoub+1
-1 continue
-4 continue
-c
-c count forward to next non-0 nodur. Start at ip in case last note of xtup.
-c
- do 3 iip = ip , 200
-c
-c Count doubled xtup notes from ip to end.
-c
- if (btest(nacc(ivx,iip),18)) ndoub = ndoub+1
- if (nodur(ivx,iip) .gt. 0) then
-c fnote = nodur(ivx,iip)/float(iip-ip1m1)
- fnote = nodur(ivx,iip)/float(iip-ip1m1+ndoub)
- if (btest(nacc(ivx,ip),18)) then
- fnote = 2*fnote
- else if (btest(nacc(ivx,ip),27)) then
- fnote = 1.5*fnote
- else if (ip .gt. 1) then
- if (btest(nacc(ivx,ip-1),27)) fnote = .5*fnote
- end if
- return
- end if
-3 continue
- print*,' '
- call printl
- * ('Probable misplaced barline or incorrect meter, stopping')
- print*,'ivx,ip:',ivx,ip
- call stop1()
- end
- subroutine g1etchar(lineq,iccount,charq)
- parameter(nm=24)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,issegno,isheadr,isvolt,fbon
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac
- character*1 charq
- character*128 lineq,lnholdq
-c
-c Gets the next character out of lineq*128. If pointer iccount=128 on entry,
-c then reads in a new line. Resets iccount. Ends program if no more input.
-c
- if (iccount .eq. 128) then
- call read10(lineq,lastchar)
- if (lastchar) return
- if (.not.endmac) then
- iccount = 0
- if (.not.mplay) nline = nline+1
- else
- endmac = .false.
- iccount = icchold
- lineq = lnholdq
- end if
- if (mrecord) then
- call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
- end if
- end if
- iccount = iccount+1
- charq = lineq(iccount:iccount)
- return
- end
- subroutine g1etnote(loop,ifig,optimize,fulltrans)
- parameter (nm=24,nkb=3999,mv=24576,maxblks=9600)
- character*1 chax
- logical twotrem
- common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm),
- * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
- * nbars,itsofar(nm),nib(nm,15),nn(nm),
- * rest(nm,200),lenbr0,lenbr1,firstline,newmeter
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
-c * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- * ibaroff,udsp(nkb),wheadpt,sqzb(maxblks)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- common /compage/ widthpt,ptheight,hoffpt,voffpt,
- * nsyst,nflb,ibarflb(0:40),
- * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
- * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30),
- * nistaff(0:40)
- common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200)
- common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1,
- * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS
- logical lastchar,firstline,rest,loop,newmeter,fbon,issegno,barend,
- * isheadr,fulbrp,usefig,isvolt,iskchb,kchmid,plusmin,ornrpt,
- * stickyS
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /commus/ musize,whead20
- logical mrecord,mplay,endmac,shifton,gotclef,optimize
- character*128 lineq,lnholdq
- character*1 charq,dotq,dumq,durq,charlq
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,cdot
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- character*131072 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- logical novshrinktop,upslur,fontslur,ztrans,
- * WrotePsslurDefaults,cstuplet
- common /comnvst/ novshrinktop,cstuplet
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- character*51 literq(3),lyrerq(5)
- common /comligfont/ isligfont
- logical isligfont
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- logical fulltrans
- common /comsize/ isize(nm)
- common /commidisig/ midisig
- common /comis4bignv/ is4bignv,AIset
- logical is4bignv,AIset
- common /comshort/ shortfrac,codafrac,ishort,mbrsum,nmbr,nocodabn,
- * poefa
- real*4 poefa(125)
- logical nocodabn
- data literq
- * /'Literal TeX string cannot start with 4 backslashes!',
- * 'TeX string must have <129 char, end with backslash!',
- * 'Type 2 or 3 TeX string can only start in column 1!'/
- data lyrerq
- * /'pmxlyr string must end with " followed by blank!',
- * 'pmxlyr string cannot extend past position 120!',
- * 'There must be "a" or "b" here!',
- * 'There must be "+" or "-" here!',
- * 'There must be an integer here!'/
- cdot = .false.
- twotrem = .false.
-1 call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') charlq = charq
- if (lastchar) then
- if (index('/%',charlq) .eq. 0) then
- print*
- print*,'WARNING:'
- print*,'Last non-blank character is "',charlq,'", not "/,%"'
- print*,'ASCII code:',ichar(charlq)
- write(15,'(/a)')'Last non-blank character is "'//charlq//
- * '", not "/,%"'
- write(15,'(a11,2x,i3)')'ASCII code:',ichar(charlq)
-c
-c Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1.
-c
- ilbuf = ilbuf-1
- lbuf(ilbuf) = lbuf(ilbuf)+2
- bufq = bufq(1:ipbuf)//' /'
- write(15,*)'appending <blank>/'
- print*,'appending <blank>/'
- lineq = lineq(1:iccount)//' /'
- lastchar = .false.
- go to 1
- end if
- return
- end if
- if (charq .eq. ' ') then
- go to 1
- else if (charq.eq.'%' .and. iccount.eq.1) then
- iccount = 128
- go to 1
-c
-c Replacement 1/22/12 since gfortran 4.7 with -O was choking here!
-c
-c else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or.
- else if (index('abcdefg',charq).gt.0 .or.
- * charq.eq.'r') then
-c
-c This is a note/rest. gotclef is only used for checking for clef before "/"
-c
- if (cdot) go to 28
-c if (gotclef) gotclef=.false.
- idotform = 0
- numnum = 0
- plusmin = .false.
-28 nnl(ivx) = nnl(ivx)+1
- if (nnl(ivx) .gt. 200) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '>200 notes in line of music. Use smaller blocks!')
- call stop1()
- end if
- dotq = 'x'
-c
-c Check if this is 'r ' and previous note was full-bar-pause
-c
- fulbrp = charq.eq.'r' .and. lineq(iccount+1:iccount+1) .eq.' '
- * .and. nnl(ivx).gt.1 .and. rest(ivx,max(1,nnl(ivx)-1)) .and.
- * nodur(ivx,max(1,nnl(ivx)-1)) .eq. lenbar
-2 call g1etchar(lineq,iccount,durq)
- ic = ichar(durq)
- if (ic.le.57 .and. ic.ge.48) then
-c
-c Digit
-c
- if (numnum .eq. 0) then
- nnodur = ic-48
- numnum = 1
- go to 2
- else if (numnum .eq. 1) then
- if (charq .eq. 'r') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one digit allowed after rest symbol "r"!')
- call stop1()
- end if
- numnum = 2
- if (plusmin) then
- print*
- print*,'*********WARNING*********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Before version 1.2, +/- was ignored if octave was!')
- print*,
- * 'explicitly specified. May need to edit old editions'
- end if
- go to 2
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '>2 digits in note symbol!')
- call stop1()
- end if
- else if (durq.eq.'d') then
- dotq = durq
- if (lineq(iccount+1:iccount+1) .eq. 'd') then
- iddot = 1
- iccount = iccount+1
-c
-c Since we flow out, double dots won't work with other dot options
-c
- end if
- if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
-c
-c move a dot, provided a number follows.
-c
- call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789-.',durq) .eq. 0) then
-c
-c Backup, exit the loop normally
-c
- iccount = iccount-2
- go to 2
- end if
- call readnum(lineq,iccount,dumq,fnum)
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift also
-c
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789-.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected number after 2nd +/- (shift dot)!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- end if
- iccount = iccount-1
- end if
- go to 2
- else if (index('<>',durq) .gt. 0) then
-c
-c Accidental shift
-c
-c if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then
- if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
-c * 'Expected "f", "s", or "n" before "<" or ">"!')
- * 'Expected "f", "s", "n" or "A" before "<" or ">"!')
- call stop1()
- end if
- ipm = 1
- if (durq .eq. '<') ipm=-1
- call g1etchar(lineq,iccount,durq)
- if (index('123456789.0',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected number after </> (accidental shift)!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- fnum = ipm*fnum
- if (fnum.lt.-5.35 .or. fnum.gt.1.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Horizontal accidental shift must be >-5.35 and <1.0!')
- call stop1()
- end if
- iccount = iccount-1
- go to 2
- else if (index('+-',durq) .gt. 0) then
- if (charq .ne. 'r') then
- if (index('fsnA',lineq(iccount-1:iccount-1)) .gt. 0) then
- ipm = 1
- if (durq .eq. '-') ipm=-1
- if (index('0123456789',lineq(iccount+1:iccount+1))
- * .gt.0) then
-c
-c This may be start of accidental shift, but may be octave jump; then duration
-c
- icsav = iccount
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (index('+-',durq) .gt. 0) then
-c
-c This is an accid shift since there's a 2nd consecutive signed number.
-c Check size of 1st number.
-c
- if (fnum .gt. 30.5) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Vertical accidental shift must be less than 31!')
- call stop1()
- end if
- ipm = 1
- if (durq .eq. '-') ipm = -1
- call g1etchar(lineq,iccount,durq)
- if (index('1234567890.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected 2nd number of accidental shift)!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- fnum = ipm*fnum
- if (fnum.lt.-5.35 .or. fnum.gt.1.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Horiz. accidental shift must be >-5.35 and <1.0!')
- call stop1()
- end if
- iccount = iccount-1
- go to 2
- else
-c
-c Not accid shift, reset, then flow out
-c
- iccount = icsav
- end if
- end if
- end if
- plusmin = .true.
- if (numnum .eq. 2) then
- print*
- print*,'*********WARNING*********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Before version 1.2, +/- was ignored if octave was!')
- print*,
- * 'explicitly specified. May need to edit old editions'
- end if
- go to 2
-c
-c It's a rest containing +|- . Must refer to a vertical shift. Read past.
-c
- else
- call g1etchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,dum)
- if (lineq(iccount-1:iccount-1).eq.'.') iccount=iccount-1
- iccount = iccount-1
- go to 2
- end if
-c else if (index('ulare',durq) .gt. 0) then
- else if (index('ularec',durq) .gt. 0) then
- go to 2
- else if (index('LS',durq) .gt. 0) then
-c
-c Stemlength change
-c
- call g1etchar(lineq,iccount,durq)
- if (index('.0123456789:',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a number or colon here!')
- call stop1()
- end if
- if (durq .eq. ':') then
- if (.not.stickyS) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned off sticky stemlegth changes without turning on!')
- call stop1()
- end if
- stickyS = .false.
- go to 2
- end if
- call readnum(lineq,iccount,durq,dum)
-c if (dum.lt..5 .or. dum.gt.4.) then
- if ((durq.eq.'L'.and.dum.gt.20.).or.
- * (durq.eq.'S'.and.dum.gt.4.)) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Stemlength change amount too big!')
- call stop1()
- end if
- if (durq .ne. ':') then
- iccount = iccount-1
- else
- if (stickyS) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned on sticky stemshrinks when already on!')
- call stop1()
- end if
- stickyS = .true.
- end if
- go to 2
- else if (index('fsn',durq) .gt. 0) then
-c
-c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so
-c MUST come right after "f,s,n"
-c
- if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
- go to 2
- else if (durq .eq. 'p') then
- fulbrp = charq.eq.'r'
- if (.not. fulbrp) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'The option "p" only works with "r" (rest)!')
- call stop1()
- end if
- go to 2
- else if (durq .eq. 'b') then
- if (charq .ne. 'r') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You entered "b"; I expected "rb"!')
- call stop1()
- else if (numnum .eq. 2) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You entered "r" & "b" with two numbers!')
- end if
- go to 2
- else if (durq .eq. 'x') then
-c
-c Xtuplet. Count number of doubled notes (for unequal xtups)
-c
- if (btest(nacc(ivx,nnl(ivx)),18)) then
- ndoub = 1
- else
- ndoub = 0
- end if
-c
-c Will set all durations to 0 except last one.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789T',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'First char after "x" in xtuplet must be "1"-"9" or "T"!')
- call stop1()
- end if
- if (durq .eq. 'T') then
-c
-c Set a flag for checking 2nd note inputs if dot is moved
-c
- twotrem = .true.
-c
-c Check all x-tremolo inputs here; set fnum=2
-c
- fnum = 2
- call getchar(lineq,iccount,durq)
- if (index('0123 ',durq).eq.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'First char after "T" in xtuplet must be "0"-"3" or blank!')
- call stop1()
- else if (durq .ne. ' ') then
- call getchar(lineq,iccount,durq)
- if (index('0123 ',durq).eq.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This char must be "0"-"3" or blank!')
- call stop1()
- else if (durq .ne. ' ') then
- call getchar(lineq,iccount,durq)
-c
-c Probably blank unles other options entered
-c
- end if
- end if
- else
-c
-c durq is digit, normal xtup
-c
- call readnum(lineq,iccount,durq,fnum)
-c
-c Leaves durq at next char after number
-c
- if (fnum .gt. 99) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Xtuplet cannot have more than 99 notes!')
- call stop1()
- else if (index(' DFnd',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only legal characters here are " ","D","F","n"!')
- call stop1()
- end if
- end if
-c
-c End of mandatory xtup inputs. Check for options. Note D,F,d must precede n.
-c
- if (index('DF',durq) .gt. 0) then
-c
-c Double xtup note to make an un= xtup. Here, number already set, but may also
-c have used this before number was set.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- ndoub = 1
- call g1etchar(lineq,iccount,durq)
- else if (durq .eq. 'd') then
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- call g1etchar(lineq,iccount,durq)
- end if
- if (durq .eq. 'n') then
-c
-c Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'.
-c
- numshft = 0
-30 call g1etchar(lineq,iccount,durq)
- if (durq .eq. 'f') then
- go to 30
- else if (index('+-',durq) .gt. 0) then
- numshft = numshft+1
- if (numshft .eq. 3) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only 2 shifts are allowed after "n" in xtup!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character should be a digit or "."!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,snum)
- iccount = iccount-1
-c if ((numshft.eq.1 .and. snum.gt.15.1) .or.
- if ((numshft.eq.1 .and. snum.gt.64.) .or.
- * (numshft.eq.2 .and. snum.gt.1.51)) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Shift number after "n" in xtup is out of range!')
- call stop1()
- end if
- go to 30
- else if (durq .eq. 's') then
-c
-c Slope alteration for bracket
-c
- call getchar(lineq,iccount,durq)
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'For slope adjustment, this character must be "+" or "-"!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character should be a digit!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,snum)
- iccount = iccount-1
- if (nint(snum) .gt. 15) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slope adjustment cannot exceed 15!')
- call stop1()
- end if
- go to 30
- else if (index('123456789',durq) .gt. 0) then
-c
-c Unsigned integer => alternate printed number
-c
- call readnum(lineq,iccount,durq,snum)
- if (snum .gt. 15.1) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Alternate xtup number after "n" must be <16!')
- call stop1()
- end if
- iccount = iccount-1
- go to 30
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "n" in xtup!')
- call stop1()
- end if
- end if
- ntup = nint(fnum)
- do 6 itup = 2 , ntup
- nodur(ivx,nnl(ivx)) = 0
- nnl(ivx) = nnl(ivx)+1
-110 call g1etchar(lineq,iccount,durq)
- if (durq.eq.' ') then
- go to 110
- else if (durq .eq. 'o') then
-c
-c Ornament in xtup. "o" symbol must come AFTER the affected note
-c
- call g1etchar(lineq,iccount,dumq)
- if (index('(stmx+Tup._)e:>^bc',dumq) .eq. 0 ) then
- if (index('fg',dumq) .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Fermata or segno not allowed in xtuplet!')
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal ornament!')
- end if
- call stop1()
- end if
- if (dumq .eq. 'T') then
-c
-c Trill. may be followed by 't' and/or number. read 'til blank
-c
-29 call g1etchar(lineq,iccount,dumq)
- if (dumq .ne. ' ') go to 29
- else if (dumq .eq. 'e') then
- call g1etchar(lineq,iccount,dumq)
- if (index('sfn?',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "e" in edit. accid. symbol!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq)
- else if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '":" must be followed by blank in "o: "!')
- call stop1()
- else if (.not.ornrpt) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Turned off repeated ornaments before they were on!')
- call stop1()
- end if
- ornrpt = .false.
- else
- call g1etchar(lineq,iccount,dumq)
- end if
- if (index('+- :',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in ornament symbol!')
- call stop1()
- end if
- if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '":" must be followed by blank in "o: "!')
- call stop1()
- else if (ornrpt) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned on repeated ornaments but already on!')
- call stop1()
- end if
- ornrpt = .true.
- end if
- if (index('+-',dumq) .gt. 0) then
- if (index('0123456789',lineq(iccount+1:iccount+1))
- * .eq. 0) then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'There should be an integer here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (durq .eq. ':') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot shift AND repeat an ornament!')
- call stop1()
- end if
-c
-c 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas.
-c
- if (index('+-',durq) .gt. 0) then
- if (index('.0123456789',lineq(iccount+1:iccount+1))
- * .eq. 0) then
- call errmsg(lineq,iccount+1,
- * ibarcnt-ibaroff+nbars+1,
- * 'There should be a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- end if
- end if
- go to 110
- else if (index('st(){}',durq) .gt. 0) then
-c
-c Slur in xtup
-c
- iposn = 0
- numint = 0
-15 call g1etchar(lineq,iccount,dumq)
- iposn = iposn+1
- if (index('udlbfnhtv',dumq) .gt. 0) then
- if (dumq.eq.'t' .and. durq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot use "t" as an option on a tie!')
- call stop1()
- end if
- go to 15
- else if (index('+-',dumq) .gt. 0) then
- numint = numint+1
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (numint .eq. 1) then
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- else if (numint .eq. 2) then
- if (abs(fnum).gt.6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in the range (-6.3,6.3)!')
- call stop1()
- end if
- else
-c
-c Third signed integer, must be a midslur or curve spec.
-c
- if (abs(fnum).gt.31) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur midheight must be in the range (-31,31)!')
- call stop1()
- end if
- if (durq .eq. ':') then
-c
-c Expecting curve parameters. Get two numbers
-c
- do 40 i = 1 , 2
- iccount = iccount+1
- fnum = ichar(lineq(iccount:iccount))-48
- if (abs(fnum-3.5) .gt. 3.6) then
- call errmsg(lineq,iccount,
- * ibarcnt-ibaroff+nbars+1,
- * 'Slur curve parameter must be in range (0,7)!')
- call stop1()
- end if
-40 continue
- iccount = iccount+1
- end if
- end if
- iccount = iccount-1
- go to 15
-
- else if (dumq .eq. 's') then
-c
-c What follows should be one or two signed numbers for adjustment of line break
-c slur, end of 1st segment or start of second.
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'May not use linebreak slur options with font-based slurs!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character must be "+" or "-"!')
- call stop1()
- end if
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- if (index('+-',dumq) .gt. 0) then
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (abs(fnum) .gt. 6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in range (-6.3,6.3)!')
- call stop1()
- end if
- end if
- iccount = iccount-1
- go to 15
- else if (dumq .eq. 'H' .and. iposn.gt.1) then
- if (lineq(iccount+1:iccount+1) .eq. 'H')
- * iccount=iccount+1
- go to 15
- else if (dumq .eq. 'p') then
-c
-c local change in postscript slur/tie adjustment default
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must use postscript slurs ("Ap") to use this option!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "+" or "-" here!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('st',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "s" or "t" here!')
- call stop1()
- end if
- go to 15
- else if (dumq .ne. ' ') then
- ic = ichar(dumq)
- if ((ic.ge.48.and.ic.le.57) .or.
- * (ic.ge.65.and.ic.le.90)) then
- if (iposn .eq. 1) then
- if (durq.eq.'t' .and. fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID not allowed on non-postscript tie!')
- call stop1()
- end if
- if (lineq(iccount+1:iccount+1).eq.'x')
- * iccount = iccount+1
- go to 15
- end if
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID must be 2nd character in slur symbol!')
- call stop1()
- end if
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in slur symbol!')
- call stop1()
- end if
- go to 110
- else if (index('0123456789#-nx_',durq) .gt. 0) then
-c
-c We have a figure. Only allow on 1st note of xtup
-c
- if (itup .ne. 2) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Figure in xtup only allowed on 1st note!')
- call stop1()
- else if (durq.eq.'x') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'No floating figures in xtuplets!')
- call stop1()
- end if
- if (usefig .and. ivx.eq.1) ifig = 1
-26 call g1etchar(lineq,iccount,durq)
-c if (index('0123456789#-n_.:',durq) .gt. 0) then
- if (index('0123456789#-n_.:v',durq) .gt. 0) then
- go to 26
- else if (durq .eq. 's') then
- isligfont = .true.
- go to 26
- else if (durq .eq. '+') then
-c
-c vertical offset, must be integer then blank
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .ne. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Integer for vertical offset expected here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Vertical offset must terminate figure!')
- call stop1()
- end if
- iccount = iccount-1
- go to 26
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in figure in xtuplet!')
- call stop1()
- end if
- go to 110
- else if (durq .eq. 'G') then
- ngr = 1
-79 call g1etchar(lineq,iccount,charq)
- if (index('123456789',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- ngr = nint(fnum)
- iccount = iccount-1
- go to 79
- else if (index('AWulxs',charq) .gt. 0) then
- go to 79
- else if (charq .eq. 'm') then
- call g1etchar(lineq,iccount,charq)
- if (index('01234',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A digit less than 5 must follow "m" in a grace note!')
- call stop1()
- end if
- go to 79
- else if (charq .eq. 'X') then
-c
-c Space before main note
-c
- call g1etchar(lineq,iccount,charq)
- if (index('0123456789.',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 79
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A number must follow "X" in a grace note!')
- call stop1()
- end if
- end if
-c
-c At this point, charq is first note name in rest (grace?)
-c
- do 71 igr = 1 , ngr
- numnum = 0
- if (igr .gt. 1) then
-75 call g1etchar(lineq,iccount,charq)
- if (charq .eq. ' ') go to 75
- end if
- if (index('abcdefg',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In grace, expected "a"-"g"!')
- call stop1()
- end if
-78 call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') then
- if (index('1234567',charq) .gt. 0) then
- if (numnum .eq. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one of "+-1234567" allowed here in grace!')
- call stop1()
- end if
- numnum = 1
- go to 78
- else if (index('+-nfs',charq) .gt. 0) then
- go to 78
- end if
-c
-c Digits are possible octave numbers
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after note name in grace!')
- call stop1()
- end if
-71 continue
- go to 110
- else if (durq .eq. chax(92)) then
- call chklit(lineq,iccount,literr)
- if (literr .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * literq(literr))
- call stop1()
- end if
- go to 110
- else if (durq .eq. '"') then
-c
-c pmx lyric
-c
- call chkpmxlyr(lineq,iccount,lyrerr)
- if (lyrerr .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * lyrerq(lyrerr))
- call stop1()
- end if
- go to 110
- else if (durq .eq. 'M') then
-c
-c Temporary trap until I get around putting this in pmxb
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Macros not yet allowed in xtuplets!')
- call stop1()
- else if (durq .eq. 'X') then
- call g1etx(lineq,iccount,shifton,
- * ibarcnt-ibaroff+nbars+1,udsp(ibarcnt+nbars+1),wheadpt)
- go to 110
- else if (durq .eq. 'z') then
-c
-c Chord note in xtup. Read past for now.
-c
-33 call g1etchar(lineq,iccount,durq)
- if (durq .ne. ' ') go to 33
- go to 110
- else if (durq .eq. 'D') then
-c
-c Dynamic mark
-c
- call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1)
- go to 110
- else if (durq .eq. '%') then
- if (iccount .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Comment must have "%" in column 1!')
- call stop1()
- end if
- iccount = 128
- go to 110
- else if (durq .eq. '?') then
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- go to 110
- end if
- if (durq .ne. '-') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting "-"')
- call stop1()
- end if
- call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting number')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 110
-c
-c 140215 Allow clef change inside xtup
-c
- else if (durq .eq. 'C') then
- call g1etchar(lineq,iccount,durq)
- if (.not.(index('tsmanrbf',durq).gt.0 .or.
-c * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then
- * (ichar(durq).ge.48 .and. ichar(durq).le.56))) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have t,s,m,a,n,r,b,f or 0-8 after C!')
- call stop1()
- end if
-c gotclef = .true.
- go to 110
-c+++
- else if (durq.eq.']' .and. lineq(iccount+1:iccount+1).eq.'['
- * .and. lineq(iccount+2:iccount+2).eq.' ') then
- iccount = iccount+2
- go to 110
-c+++
-c
-c Added 200118 to allow dot to be moved on 2nd note of 2-note tremolo
-c
- end if
-c
-c End of xtup options. At this point symbol can only be note or rest
-c
- if (index('abcdefgr',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In xtup, this character is not allowed!')
- call stop1()
- end if
-7 call g1etchar(lineq,iccount,durq)
- if (index('12345678ulcb',durq) .gt. 0) then
- go to 7
- else if (index('sfn',durq) .gt. 0) then
-c
-c Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift.
-c
- if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
- go to 7
- else if (index('+-<>',durq) .gt. 0) then
-c
-c May have either octave jump or shifted accid. on main xtup note
-c
- if (index('+-',durq).gt.0 .and.
- * index('01234567890',lineq(iccount+1:iccount+1)).eq.0)
- * go to 7
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 7
- else if (index('DF',durq) .gt. 0) then
-c
-c Double an xtup note to make an unequal xtup
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- ndoub = ndoub+1
- go to 7
- else if (durq .eq. 'd') then
- if (twotrem) then
-c
-c 2-note trem, get shift
-c
- call g1etchar(lineq,iccount,durq)
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected +/- for shifted dot on end of 2-note trem!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,dumq,fnum)
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift also
-c
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789-.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected number after 2nd +/- (shift dot)!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- end if
- iccount = iccount-1
- go to 7
- else
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- end if
- go to 7
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal option on xtuplet note!')
- call stop1()
- end if
- if (itup .eq. ntup-ndoub) go to 3
-6 continue
-3 continue
-c
-c 6==End of loop for xtuplet input
-c
- else if (durq .eq. 'm') then
-c
-c Multi-bar rest: next 1 or two digits are # of bars.
-c
- if (mod(itsofar(iv),lenbar) .ne. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Multibar rest must start at beginning of bar!')
- call stop1()
- else if (iv.eq.1.and.ibarmbr.gt.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Multibar rest only OK at one time per block!')
- call stop1()
- end if
-c
-c For some purposes, pretend its one bar only
-c
- nodur(iv,nnl(iv)) = lenbar
- ibarmbr = nbars+1
- mbrest = 0
-c20 call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected an integer after "rm"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- mbrest = nint(fnum)
-c iccount = iccount-1
- if (nv .gt. 1) then
- if (iv .eq. 1) then
- mbrestsav = mbrest
- else
- if (mbrest .ne. mbrestsav) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must enter same multi-bar rest in every voice!')
- call stop1()
- end if
- end if
-c
-c Zero out mbrestsav so can check at end of input block whether
-c all voices have one
-c
- if (iv .eq. nv) mbrestsav=0
- end if
- if (durq .eq. 'n') then
-c
-c Get new height
-c
- call g1etchar(lineq,iccount,durq)
- if (index('+-123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected an integer after "rm[x]n"!')
- call stop1()
- end if
- if (index('+-',durq).ne.0) iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- end if
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "rm"!')
- call stop1()
- end if
- else if (durq .eq. '.') then
-c
-c Dotted pattern. Close out note. Mult time by 3/4.
-c Set time for next note to 1/4. Start the note.
-c
- idotform = 1
- else if (durq .eq. ',') then
- idotform = 3
-c
-c Now flow to duration setting, as if durq=' '
-c
- else if (index('oL',durq) .gt. 0) then
-c
-c Suppress full bar rest, or look left for height
-c
- if (charq .ne. 'r') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"o","L" options only legal for rest, not note!')
- call stop1()
- end if
- go to 2
- else if (index('DF',durq) .gt. 0) then
-c
-c Double note for xtup. Must check here in case "D" or "F" came before "x" or on
-c last note of xtup. Need to flag it in pmxa since affects horiz. spacing.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- go to 2
- else if (durq .eq. 'A') then
-c
-c Main note accidental option
-c
- call getchar(lineq,iccount,durq)
- if (index('o+-<>',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"o",+","-","<",">" are the only legal options here!')
- call stop1()
- end if
-c
-c Need more stuff here
-c
- if (durq .ne. "o") then
-c
-c Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will
-c proceed to number input checking
-c
- iccount = iccount-1
- end if
- go to 2
- else if (durq .eq. 'T') then
-c
-c Single stem tremolo. Only option (optional) is 1,2,3, or 4.
-c
- call getchar(lineq,iccount,durq)
- if (index('1234',durq) .eq. 0) iccount = iccount-1
- go to 2
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character!')
- print*,'ASCII code:',ichar(durq)
- call stop1()
- end if
-c
-c End of block for note options.
-c
-c Set the duration
-c
- if (idotform .gt. 0) then
- if (idotform .eq. 1) then
- nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)*3/2
- else if (idotform .eq. 2) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3
- else if (idotform .eq. 3) then
- nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)
- else if (idotform .eq. 4) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2
- end if
- else if (ibarmbr.ne.nbars+1 .and. .not.fulbrp) then
- nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)
-c
-c Check for double dot
-c
- if (iddot .eq. 1) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6
- iddot = 0
- end if
- else if (fulbrp) then
- nodur(ivx,nnl(ivx)) = lenbar
-c
-c Use a one-line function to set nnodur. It gives inverse of ifnodur.
-c
- nnodur = index('62514x0x37',
- * chax(48+int(log(.1+lenbar)/.69315)))-1
- fulbrp = .false.
- end if
- rest(ivx,nnl(ivx)) = charq.eq.'r'
-c
-c If inside forced beam, check if note is beamable
-c
- if (fbon) then
- if (nodur(ivx,nnl(ivx)) .lt. 16) go to 120
- if (nnl(ivx) .gt. 1) then
- if (nodur(ivx,nnl(ivx)-1) .eq. 0) go to 120
- end if
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Unbeamable thing in forced beam!')
- call stop1()
- end if
-120 continue
-c
-c Get number of prior bars for later check on whether note spans bar line
-c
- nbb4 = itsofar(ivx)/lenbar
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- if (mod(itsofar(ivx),lenbar) .eq. 0) then
- nbars = nbars+1
- if (shifton) barend = .true.
-c
-c Will check barend when 1st note of next bar is entered.
-c
- if (nbars .gt. 15) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot have more than 15 bars in an input block!')
- call stop1()
- end if
- nib(ivx,nbars) = nnl(ivx)
- if (firstline .and. lenbar.ne.lenbr1) then
-c
-c Just finished the pickup bar for this voice.
-c
- if (itsofar(ivx) .ne. lenbr0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Pickup bar length disagrees with mtrnum0!')
- call stop1()
- end if
- lenbar = lenbr1
- itsofar(ivx) = 0
- end if
- else if (barend) then
- if (shifton) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar ended with user-defined shift still on!')
- call stop1()
- end if
- barend = .false.
- else if (itsofar(ivx)/lenbar .gt. nbb4) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'This note spans a bar line!')
- call stop1()
- end if
- if (idotform.eq.1 .or. idotform.eq.3) then
- call g1etchar(lineq,iccount,charq)
- if (index('abcedfgr',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected note name or "r" here!')
- call stop1()
- end if
- idotform = idotform+1
- numnum = 1
- go to 28
- end if
-c
-c End of sub block for note-rest
-c
- else if (charq .eq. 'z') then
- call g1etchar(lineq,iccount,charq)
- if (index('abcdefg',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected chord note name here!')
- call stop1()
- end if
-25 call g1etchar(lineq,iccount,durq)
-c if (index('dre12345678',durq) .gt. 0) then
- if (index('dre12345678c',durq) .gt. 0) then
- go to 25
- else if (index('fsn',durq) .gt. 0) then
-c
-c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so
-c MUST come right after "f,s,n"
-c
- if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
- go to 25
- else if (durq .eq. 'A') then
- if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Must have "f,s,n" before "A" in chord note!')
- call stop1()
- end if
- go to 25
- else if (index('<>',durq) .gt. 0) then
- if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then
-c if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Must have "f,s,n,A" before "<" or ">"!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('1234567890.',durq) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number to start here for accidental shift!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 25
- else if (index('+-',durq) .gt. 0) then
- if (index('1234567890.',lineq(iccount+1:iccount+1)) .eq. 0)
- * go to 25
-c
-c Number or '.' (durq) follows +/- . Get it.
-c
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. '.' .and. index('1234567890',
- * lineq(iccount+1:iccount+1)) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * '"." here must be followed by a digit!')
- call stop1()
- else if (index('sfndA',lineq(iccount-2:iccount-2)).eq.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Number after +/- must follow "d,s,f,n,A"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (index('+-',durq) .eq. 0) then
- iccount = iccount-1
- go to 25
- end if
-c
-c 2nd +/-
-c
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. '.') call g1etchar(lineq,iccount,durq)
- if (index('1234567890',durq) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 25
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in chord note!')
- call stop1()
- end if
- else if (charq .eq. 'G') then
- ngr = 1
-9 call g1etchar(lineq,iccount,charq)
- if (index('123456789',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- ngr = nint(fnum)
- iccount = iccount-1
- go to 9
- else if (index('AWulxs',charq) .gt. 0) then
- go to 9
- else if (charq .eq. 'm') then
- call g1etchar(lineq,iccount,charq)
- if (index('01234',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A digit less than 5 must follow "m" in a grace note!')
- call stop1()
- end if
- go to 9
- else if (charq .eq. 'X') then
-c
-c Space before main note
-c
- call g1etchar(lineq,iccount,charq)
- if (index('0123456789.',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 9
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A number must follow "X" in a grace note!')
- call stop1()
- end if
- end if
-c
-c At this point, charq is first note name in rest (grace?)
-c
- do 19 igr = 1 , ngr
- numnum = 0
- if (igr .gt. 1) then
-55 call g1etchar(lineq,iccount,charq)
- if (charq .eq. ' ') go to 55
- end if
- if (index('abcdefg',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In grace, expected "a"-"g"!')
- call stop1()
- end if
-18 call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') then
- if (index('1234567',charq) .gt. 0) then
- if (numnum .eq. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one of "+-1234567" allowed here in grace!')
- call stop1()
- end if
- numnum = 1
- go to 18
-c else if (index('nfs',charq) .gt. 0) then
- else if (index('+-nfs',charq) .gt. 0) then
- go to 18
- end if
-c
-c Digits are possible octave numbers
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after note name in grace!')
- call stop1()
- end if
-19 continue
- else if (charq .eq. chax(92)) then
- call chklit(lineq,iccount,literr)
- if (literr .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * literq(literr))
- call stop1()
- end if
- else if (charq .eq. '"') then
-c
-c pmx lyric
-c
- call chkpmxlyr(lineq,iccount,lyrerr)
- if (lyrerr .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * lyrerq(lyrerr))
- call stop1()
- end if
- else if (charq .eq. 'o') then
-c
-c Ornament on non-xtup note. "o" symbol must come AFTER the affected note
-c
- if (nnl(ivx) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"o" must be in same input block, after affected note!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
-c if (index('(stmgx+Tupf._)e:>^bc',dumq) .eq. 0 ) then
- if (index('(stmgx+Tupf._)e:>^bcCG',dumq) .eq. 0 ) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal ornament!')
- call stop1()
- end if
- if (dumq .eq. ':') then
- call g1etchar(lineq,iccount,dumq)
- if (dumq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected blank after "o:"!')
- call stop1()
- else if (.not.ornrpt) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Turned off repeated ornaments before they were on!')
- call stop1()
- end if
- ornrpt = .false.
- else if (dumq .eq. 'g') then
- if (issegno) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Sorry, only one "segno" per input block!')
- call stop1()
- else if (ivx .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'segno can only be in voice 1!')
- call stop1()
- end if
- issegno = .true.
-12 call g1etchar(lineq,iccount,dumq)
- if (dumq.eq.'-' .or.
- * (ichar(dumq).ge.48.and.ichar(dumq).le.58)) go to 12
- if (dumq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in segno ornament symbol!')
- call stop1()
- end if
- else if (dumq .eq. 'T') then
-c
-c Trill. may be followed by 't' and/or number. read 'til blank
-c
-22 call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected blank after ":"!')
- call stop1()
- end if
- go to 32
- else if (dumq .ne. ' ') then
- go to 22
- end if
- else if (dumq .eq. 'f') then
- call g1etchar(lineq,iccount,dumq)
- if (index(' d+-:',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "f" in fermata ornament symbol!')
- call stop1()
- end if
- if (dumq .eq. 'd') call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. ':') go to 32
- else if (dumq .eq. 'e') then
- call g1etchar(lineq,iccount,dumq)
- if (index('sfn?',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "e" in edit. accid. symbol!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq)
- else
- call g1etchar(lineq,iccount,dumq)
- end if
- if (index('+- :',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in ornament symbol!')
- call stop1()
- end if
- if (index('+-',dumq) .gt. 0) then
- if (index('0123456789',lineq(iccount+1:iccount+1)).eq.0) then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'There should be an integer here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (durq .eq. ':') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot shift AND repeat an ornament!')
- call stop1()
- end if
-c
-c 12/7/03 Allow horizontal shift on any ornament, not just breath and caes.
-c
- if (index('+-',durq) .gt. 0) then
- if (index('.0123456789',lineq(iccount+1:iccount+1))
- * .eq. 0) then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'There should be a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- end if
- end if
-32 continue
- if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '":" must be followed by blank in "o: "!')
- call stop1()
- else if (ornrpt) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned on repeated ornaments but already on!')
- call stop1()
- end if
- ornrpt = .true.
- end if
- else if (index('st(){}',charq) .gt. 0) then
- numint = 0
- iposn = 0
-8 call g1etchar(lineq,iccount,dumq)
- iposn = iposn+1
- if (charq.eq.'t' .and. dumq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot use "t" as an option on a tie!')
- call stop1()
- end if
- if (index('udltb+-fnhHpsv ',dumq) .eq. 0) then
-c
-c Check for explicit ID code.
-c
- ic = ichar(dumq)
- if (ic.lt.48 .or. (ic.gt.57.and.ic.lt.65) .or.
- * ic.gt.90) then
-c
-c Not 0-9 or A-Z, so exit
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in slur symbol!')
- call stop1()
- else
-c
-c It is a possible ID code. Right place?
-c
- if (iposn .ne. 1) then
-c
-c Slur ID is not 2nd!
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID must be second character in slur symbol!')
- call stop1()
- else if (charq.eq.'t' .and. fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID not allowed on non-postscript tie!')
- call stop1()
- else if (lineq(iccount+1:iccount+1).eq.'x') then
- iccount = iccount+1
- end if
- end if
-c
-c Slur ID is OK. Note it cannot be "H" at this point..
-c
- go to 8
- else if (dumq .eq. 'H') then
- if (iposn .eq. 1) go to 8
-c
-c "H" is NOT an ID code.
-c
- if (.not.fontslur .and. charq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot reshape postscript ties this way!')
- call stop1()
- end if
- if (lineq(iccount+1:iccount+1) .eq. 'H') then
- iccount=iccount+1
- iposn = iposn+1
- end if
- go to 8
- else if (index('fh',dumq).gt.0 .and. .not.fontslur
- * .and. charq.eq.'t') then
-c
-c 3/9/03 Can't reshape postscript tie.
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot reshape postscript ties this way!')
- call stop1()
- else if (dumq .eq. 'p') then
-c
-c local change in postscript slur/tie adjustment default
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must use postscript slurs ("Ap") to use this option!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "+" or "-" here!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('st',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "s" or "t" here!')
- call stop1()
- end if
- iposn = iposn+2
- go to 8
- end if
- if (index('udltbfnh',dumq) .gt. 0) then
- go to 8
- else if (index('+-',dumq) .gt. 0) then
- numint = numint+1
- if (fontslur .and. charq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"+|-" for slur height only allowed in "s"-slurs!')
- call stop1()
- end if
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (numint .eq. 1) then
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- else if (numint .eq. 2) then
- if (abs(fnum) .gt. 6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in range (-6.3,6.3)!')
- call stop1()
- end if
- else
-c
-c Third signed integer, must be a midslur or curve spec.
-c
- if (abs(fnum).gt.31) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur midheight must be in the range (-31,31)!')
- call stop1()
- end if
- if (durq .eq. ':') then
-c
-c Expecting curve parameters. Get two numbers
-c
- do 41 i = 1 , 2
- iccount = iccount+1
- fnum = ichar(lineq(iccount:iccount))-48
- if (abs(fnum-3.5) .gt. 3.6) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur curve parameter must be in range (0,7)!')
- call stop1()
- end if
-41 continue
- iccount = iccount+1
- end if
- end if
- iccount = iccount-1
- go to 8
- else if (dumq .eq. 's') then
-c
-c What follows should be one or two signed numbers for adjustment of line break
-c slur, end of 1st segment or start of second.
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'May not use linebreak slur options with font-based slurs!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character must be "+" or "-"!')
- call stop1()
- end if
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- if (index('+-',dumq) .gt. 0) then
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (abs(fnum) .gt. 6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in range (-6.3,6.3)!')
- call stop1()
- end if
- end if
- iccount = iccount-1
- go to 8
- else if (dumq .eq. 'H' .and. iposn.gt.1) then
- if (lineq(iccount+1:iccount+1) .eq. 'H') iccount=iccount+1
- go to 8
- end if
- else if (charq .eq. '?') then
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- else
- if (durq .ne. '-') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting "-"!')
- call stop1()
- end if
- call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting number!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- end if
- else if ((ichar(charq).ge.48.and.ichar(charq).le.57) .or.
- * index('#-nx_',charq) .gt. 0) then
-c
-c We have a figure. Must come AFTER the note it goes under
-c
- if (itsofar(ivx).eq.0 .and.
- * (.not.firstline.or.lenbr0.eq.0.or.lenbar.eq.lenbr0)) then
-c
-c Figure before first note in block
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot put figure before first note in block!')
- call stop1()
- end if
- if (charq.eq.'x') then
- indxb = index(lineq(iccount:128),' ')
- if (indxb .lt. 5) then
- call errmsg(lineq,iccount+indxb-1,ibarcnt-ibaroff+nbars+1,
- * 'Cannot have a blank here in floating figure!')
- call stop1()
- end if
- end if
- if (usefig) ifig = 1
-5 call g1etchar(lineq,iccount,charq)
- if (index(' 0123456789#-nx_.:+sv',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in figure!')
- call stop1()
- else if (charq .eq. '+') then
-c
-c vertical offset, must be integer, then blank
-c
- call g1etchar(lineq,iccount,charq)
- if (index('123456789',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Integer for vertical offset expected here!')
- call stop1()
- end if
- call readnum(lineq,iccount,charq,fnum)
- if (charq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Vertical offset must terminate figure!')
- call stop1()
- end if
- iccount = iccount-1
- go to 5
- else if (charq .eq. 's') then
- isligfont = .true.
- end if
- if (charq .ne. ' ') go to 5
- else if (charq .eq. '[') then
- if (fbon) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Started forced beam while another was open!')
- call stop1()
- end if
- fbon = .true.
-17 call g1etchar(lineq,iccount,charq)
- if (index('uljhf:',charq) .gt. 0) then
- go to 17
- else if (index('+-',charq) .gt. 0) then
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 17
- else if (charq .eq. 'm') then
-c
-c Forced multiplicity, next char should be 1-4
-c
- call g1etchar(lineq,iccount,charq)
- if (index('1234',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Forced multiplicity for a beam must be 1, 2, 3, or 4!')
- call stop1()
- end if
- go to 17
- else if (charq .ne. ' ') then
- if (index('0123456789',charq) .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'After "[", digits must now be preceeded by "+" or "-"!')
- print*,'You will have to edit older sources to meet this rqmt,'
- print*,'but it was needed to allow 2-digit height adjustments.'
- print*,'Sorry for the inconvenience. --The Management'
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after [!')
- end if
- call stop1()
- end if
- else if (charq .eq. ']') then
- if (.not.fbon) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Forced beam stop with no corresponding start!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,charq)
- if (charq .eq. '-') then
- if (lineq(iccount+1:iccount+2) .ne. '[ ') then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'Only sequence allowed here is "[ "!')
- call stop1()
- else
- iccount = iccount+2
- end if
- else if (charq .eq. '[') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'This character must be a blank!')
- call stop1()
- end if
- else
-c
-c Forced beam is really ending
-c
- fbon = .false.
- if (charq .eq. 'j') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'This character must be a blank!')
- call stop1()
- end if
- else if (charq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"]" must be followed by blank, "j", "-", or "["!')
- call stop1()
- end if
- end if
- else if (charq .eq. 'D') then
-c
-c Dynamic mark
-c
- if (nnl(ivx) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"D" must not come before any notes have been entered!')
- call stop1()
- end if
- call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1)
- else if (index('lhw',charq) .gt. 0) then
-c
-c Save position for later check
-c
- icclhw = iccount
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789.+- ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "l", "w", or "h"!')
- call stop1()
- end if
- isheadr = isheadr .or. charq .eq. 'h'
- if (index(' +-',durq) .gt. 0) then
-c
-c There is a header (or lower string?)
-c
- if (index('+-',durq) .gt. 0) then
-c
-c User-defined vert offset (\internote).
-c
- if (charq .ne. 'h') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"+" or "-" not permitted here!')
- call stop1()
- end if
-c
-c Have "h" followed by +/- . Check for digit.
-c Can blow durq since not using fnum for now, but...
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a digit here!')
- call stop1()
- end if
-c
-c Have "h" followed by +/- followed by a digit. No need to get the number.
-c
-c call readnum(lineq,iccount,durq,fnum)
- end if
- if (charq .ne. 'w') then
-c
-c Header or lower string.
-c
- if (icclhw .ne. 1) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * '"h" or "l" must be first character in line!')
- call stop1()
- end if
-c
-c Read past the next line, which has the string.
-c
- call read10(charq,lastchar)
- nline = nline+1
- iccount = 128
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Symbol "w" (width) must be followed by a digit!')
- call stop1()
- end if
- else
-c
-c Height or width change spec. Check if at start of piece.
-c
- if (ibarcnt .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Symbol must go at top of first input block!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,dimen)
-c
-c Check units. Convert to points
-c
- if (durq .eq. ' ' .or. durq .eq. 'p') then
- dimen = dimen+.5
- else if (durq .eq. 'i') then
- dimen = dimen*72+.5
- else if (durq .eq. 'm') then
- dimen = dimen/25.4*72+.5
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal unit; must be "p","i",or"m"!')
- call stop1()
- end if
-c
-c 151211 fix. May have extra character.
-c
- if (index('pim',durq) .gt. 0) then
-c
-c Get another character, see if it's blank
-c
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'This character should be a blank!')
- call stop1()
- end if
- end if
- if (charq .eq. 'h') then
- ptheight = int(dimen)
- else
- widthpt = int(dimen)
- end if
- end if
- else if (charq .eq. 'm') then
-c
-c Time signature change. Only allow at beginning of block.
-c mtrnuml, mtrdenl (logical) and p (printable) will be input.
-c mtrnuml=0 initially. (In common)
-c
-c Check whether at beginning of a block
-c
- if (ivx.ne.1 .or. nnl(1).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Meter change only OK in voice 1, at start of block!')
- print*,'voice number is',ivx
- call stop1()
- end if
- newmeter = .true.
- if (index('o0123456789',lineq(iccount+1:iccount+1)).eq.0) then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in "m" command for meter change!')
- call stop1()
- end if
- call readmeter(lineq,iccount,mtrnuml,mtrdenl)
- if (mtrnuml .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Digit 0 not allowed here!')
- call stop1()
- end if
- call readmeter(lineq,iccount,mtrnmp,mtrdnp)
-c
-c Read past printed time signature; not used in pmxa.
-c
- lenbeat = i1fnodur(mtrdenl,'x')
- lenmult = 1
- if (mtrdenl .eq. 2) then
- lenbeat = 16
- lenmult = 2
- end if
- lenbar = lenmult*mtrnuml*lenbeat
- mtrnuml = 0
- else if (charq .eq. 'C') then
- call g1etchar(lineq,iccount,durq)
- if (.not.(index('tsmanrbf',durq).gt.0 .or.
- * (ichar(durq).ge.48 .and. ichar(durq).le.56))) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have t,s,m,a,n,r,b,f or 0-8 after C!')
- call stop1()
- end if
- else if (charq .eq. 'R') then
- if (ivx .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Repeats can only go in voice 1!')
- call stop1()
- end if
-c10 call g1etchar(lineq,iccount,durq)
-c if (index('lrdDbz',durq) .gt. 0) go to 10
-c if (durq .ne. ' ') then
-c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'Illegal character after "R" (repeat/double bar)!')
-c call stop1()
-c end if
- call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,dumq)
- if (index('l Xr Xd XD Xb Xz XlrXdlX',durq//dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "R*" (repeat/double bar)!')
- call stop1()
- end if
- if (dumq .ne. ' ') then
- call g1etchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have blank after "R**" (repeat/double bar)!')
- call stop1()
- end if
- end if
- else if (charq .eq. 'V') then
-c
-c Ending
-c
- if (iv .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Voltas are only allowed in voice #1!')
- call stop1()
- else if (isvolt) then
- print*
- print*,'*******WARNING********'
- write(15,'(/,a)')'*******WARNING********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There is more than one volta in this input block.!')
- print*,'This may work in a score, but WILL NOT work in parts.'
- print*,
- *'Safest to have only 1 volta per block, at the start of the block'
- write(15,'(a)')
- * 'This may work in a score, but WILL NOT work in parts.'
- write(15,'(a)')
- *'Safest to have only 1 volta per block, at the start of the block'
- end if
- isvolt = .true.
- lvoltxt = 0
-11 call g1etchar(lineq,iccount,durq)
- if (durq .ne.' ') then
- go to 11
- end if
- else if (charq .eq. 'B') then
- continue
- else if (charq .eq. 'P') then
- if (ivx.ne.1 .or. nnl(1).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only allowed at beginning of block!')
- call stop1()
- end if
-16 call g1etchar(lineq,iccount,durq)
- if (durq.eq.'l'.or.durq.eq.'r'.or.(ichar(durq).ge.48 .and.
- * ichar(durq).le.57)) go to 16
- if (durq .eq. 'c') then
-c
-c Expect a centered name, and it has to be last option
-c
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. '"') then
-c
-c Quoted name, go to next quote mark
-c
- do 35 iccount = iccount+1 , 127
- if (lineq(iccount:iccount).eq.'"' .and.
- * lineq(iccount-1:iccount-1).ne.'\') go to 36
-35 continue
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Missing close quote after page number command (P)!')
- call stop1()
-36 continue
- else if (durq .ne. ' ') then
-c
-c Space-delimited name, look for next blank
-c
- do 37 iccount = iccount+1 , 127
- if (lineq(iccount:iccount) .eq. ' ') go to 38
-37 continue
-38 continue
- end if
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only "l","r","c" or digit allowed after "P"!')
- call stop1()
- end if
- else if (charq .eq. 'W') then
- call g1etchar(lineq,iccount,durq)
- if (index('.0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number to start here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,wminnh(ibarcnt+nbars+1))
- else if (charq .eq. 'T') then
-c
-c Titles
-c
- call g1etchar(lineq,iccount,durq)
- if (index('itc',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must put "i", "t", or "c" after "T"!')
- call stop1()
- end if
- ihead = ihead+2**(index('itc',durq)-1)
-c
-c Maybe a number after 'Tt', but ignore here. Read past string on next line.
-c
- call read10(charq,lastchar)
- nline = nline+1
- iccount = 128
- else if (charq .eq. 'A') then
-27 call g1etchar(lineq,iccount,durq)
-c if (index('rbsdeK',durq) .gt. 0) then
- if (index('rbsdK',durq) .gt. 0) then
- go to 27
- else if (durq .eq. 'e') then
-c
-c Check for is4bignv. Must do here to catch first \internote, written in topfile
-c before ever calling getnote. Initialize as .false. in pmxa. Make it true only
-c if nv>7, AI not set, Ai not set.
-c
- is4bignv = nv.gt.7 .and. .not.AIset
- go to 27
- else if (durq .eq. 'v') then
- if (ibarcnt .eq. 0) novshrinktop = .true.
- go to 27
- else if (durq .eq. 'a') then
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'After "Aa", need decimal number!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fbar)
- iccount = iccount-1
- go to 27
- else if (durq .eq. 'i') then
- is4bignv = .false.
- AIset = .true.
- call g1etchar(lineq,iccount,durq)
-c
-c Local interstaff correction. Set to -1. if not specifiec, or after use,
-c or anytime except at top, since pmxb handles all times except at top.
-c
- call readnum(lineq,iccount,durq,tintstf)
- if (ibarcnt .eq. 0) fintstf = tintstf
- iccount = iccount-1
- go to 27
- else if (durq .eq. 'I') then
-c
-c Global interstaff correction. Use in place of fintstf if fintstf<0
-c
- is4bignv = .false.
- AIset = .true.
- call g1etchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,gintstf)
- iccount = iccount-1
- go to 27
- else if (durq .eq. 'o') then
- optimize = .true.
- go to 27
- else if (durq .eq. 'S') then
- do 50 iiv = 1 , noinst
- call g1etchar(lineq,iccount,durq)
- if (index('-0st',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'After "AS", need nv instances of "s,t,-,0"!')
- call stop1()
- end if
- if (durq.eq.'-'.or.durq.eq.'s') then
- isize(iiv) = 1
- else if (durq.eq.'t') then
- isize(iiv) = 2
- end if
-50 continue
- go to 27
- else if (durq .eq. 'p') then
- fontslur = .false.
-42 continue
- call g1etchar(lineq,iccount,durq)
- if (index('+-',durq) .gt. 0) then
-c
-c Characters to change defaults for ps slurs
-c
- call g1etchar(lineq,iccount,durq)
- if (index('shtc',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only letters allowed here are "s","h","t","c"!')
- call stop1()
- end if
-c
-c Now check for another default modifier
-c
- go to 42
- else if (index('lh',durq) .gt. 0) then
-c
-c Flags for optional linebreak ties or header specials
-c
- go to 42
- else
- iccount = iccount-1
- end if
- go to 27
- else if (durq .eq. 'N') then
-c
-c Override default name for a part file. Must have part number, then
-c partname in quotes. Must be on line by itself, and start in column 1.
-c Will only be passed thru to scor2prt.
-c
- if (iccount .ne. 2) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"AN" must start in column 1!')
- call stop1()
- end if
- ndxquote = index(lineq,'"')
- if (ndxquote.lt.4 .or. ndxquote.gt.5 .or.
- * index('123456789',lineq(3:3)).eq.0 .or.
- * (ndxquote.eq.5.and.index('012',lineq(4:4)).eq.0)) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"AN" must be followed by inst. #, then quote!')
- call stop1()
- end if
- ndxquote = index(lineq(ndxquote+1:128),'"')
- if (ndxquote .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In "AN", file name must be in quotes!')
- call stop1()
- end if
- iccount = 128
- else if (durq .eq. 'T') then
- cstuplet = .true.
- else if (durq .eq. 'R') then
-c
-c Get full name of normal include file; must occupy remainder of line
-c
- call getpmxmod(.false.,lineq(iccount+1:128))
- iccount = 128
- else if (durq .eq. 'c') then
- call g1etchar(lineq,iccount,durq)
- if (index('l4',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only "l" or "4" is allowed here!')
- call stop1()
- end if
- if (durq .eq. 'l' ) then
- hoffpt = -25
- voffpt = -45
- else if (durq .eq. '4') then
- ptheight = 745
- widthpt = 499
- hoffpt = -24
- voffpt = -24
- end if
- go to 27
- else if (durq .eq. 'V') then
- call g1etchar(lineq,iccount,durq)
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only "+" or "-" is allowed here!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A number for vert shift before \eject must start here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only "+" or "-" is allowed here!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A number for vert shift after \eject must start here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 27
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'After "A" must follow one of the letters abcdeiINprRsST!')
- * 'After "A" must follow one of abcdeiILNprRsSTvV!')
- print*,'For AS, since ver. 2.7, must only have noinst args.'
- write(15,'(a)')
- * 'For AS, since ver. 2.7, must only have noinst args.'
- call stop1()
- end if
- else if (charq .eq. 'K') then
-c
-c Rules and function of K command
-c
-c Only 1 K +/-n +/-m allowed per block if n.ne.0 (transposition). isig1 is
-c initial sig, and must be passed to pmxb because it is needed when topfile
-c is called, which is before the K+n+m command is read in pmxb. Also, we
-c compute and save ibrkch and newkey for each syst, accounting for key changes,
-c then adjust fbar to make poenom much more accurate.
-c Jan 02: Now K-0+[n] is used to transpose e.g. from f to f#.
-c
-77 continue
- call g1etchar(lineq,iccount,durq)
-c if (index('+-i',durq) .eq. 0) then
- if (index('+-in',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"K" (transpose or key change) must be followed by "+,-,i,n"!')
- call stop1()
- end if
- if (durq .eq. 'n') go to 77
- if (durq .ne. 'i') then
-c
-c Normal key change and/or transposition)
-c
-c iccount = iccount+1
- num1 = 44-ichar(durq)
-c
-c num1= +1 or -1
-c
- ztrans = num1.eq.-1
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st +/- must be followed by a number!')
- call stop1()
- end if
-c iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- num1 = nint(fnum)*num1
- ztrans = ztrans .and. num1.eq.0
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st number after "K" must be followed by "+,-"!')
- call stop1()
- end if
- iccount = iccount+1
- num2 = 44-ichar(durq)
- call readnum(lineq,iccount,durq,fnum)
- num2 = num2*int(fnum+.1)
- if (num1.eq.0 .and. .not.ztrans) then
-c
-c Key change, only one per block allowed
-c
- if (iskchb) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one key change allowed per input block!')
- call stop1()
- end if
- iskchb = .true.
- nkeys = nkeys+1
- kchmid(nkeys) = mod(itsofar(ivx),lenbar).ne.0
-c
-c Make ibrkch = barnum-1 if at start of bar, so fsyst advances ok at linebreak.
-c
- ibrkch(nkeys) = ibarcnt+nbars
- if (kchmid(nkeys)) ibrkch(nkeys) = ibrkch(nkeys)+1
- newkey(nkeys) = num2+idsig
-c 130316
-c do 43 iinst = 1 , noinst
- midisig = newkey(nkeys)
-c43 continue
- else
-c
-c Transposition
-c
- fulltrans = .true.
- if (ibarcnt .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Transposition must be at top of first input block!')
- call stop1()
- end if
- isig1 = num2
- idsig = isig1-newkey(1)
-c
-c idsig is the difference between sig after transposition, and sig in setup.
-c It may alter # of accid's in key changes if there is transposition.
-c
- end if
- else ! durq='i'
-c
-c 110522/110529
-c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey]
-c and repeat i[...] for multiple instruments. Store info here if ibarcnt=0
-c so can pass to topfile (via comInstTrans), which is called before getnote.
-c Otherwise, will store info from getnote. Initialize EarlyTransOn and
-c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from here;
-c LaterInstTrans from g1etnote. Zero both out after use. nInstTrans really
-c only needed for instrument-signatures, not transpositions. iTransAmt is
-c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for
-c each staff.
-c
- call GetiTransInfo(.true.,ibarcnt,lineq,iccount,
- * ibaroff,nbars,noinst)
- end if
- else if (charq .eq. '|') then
-c
-c Optional bar symbol
-c
- if (mod(itsofar(ivx),lenbar).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar line marker out of place!')
- call stop1()
- else if (shifton) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar ended with user-defined shift still on!')
- call stop1()
- end if
- else if (charq .eq. '/') then
- if (ornrpt) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'WARNING: Block ended with repeated ornament still on!')
- ornrpt = .false.
- end if
- if (stickyS) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'WARNING: Block ended with sticky stemshrink still on!')
- stickyS = .false.
- end if
- if (fbon) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Block ended with forced beam open!')
- call stop1()
- else if (shifton) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar ended with user-defined shift still on!')
- call stop1()
-c
-c 140215 Temporary to allow clef change in stup
-c
-c else if (gotclef) then
-c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'May not enter clef at end of input block!')
-c call stop1()
- end if
- barend = .false.
-c
-c Perform time checks
-c
- if (mod(itsofar(ivx),lenbar).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Block duration not divisible by lenbar!')
- print*,'lenbar, timesofar are ',lenbar,itsofar(ivx)
- call stop1()
- else if (ivx.gt.1 .and. itsofar(ivx).ne.itsofar(1)) then
- print*
- print*,'No of bars in voice 1, current voice:',
- * itsofar(1)/lenbar,itsofar(ivx)/lenbar
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Block duration not equal to voice 1!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. ' ' .and. iv.eq.nv) then
-c
-c End of input block
-c
- loop = .false.
- else
-c
-c Start a new voice
-c
- if (lenbr0.ne.0 .and. firstline) lenbar = lenbr0
- nbars = 0
- if (durq .eq. ' ') then
-c
-c New voice is on next staff
-c
- iv = iv+1
- ivx = iv
- else
-c
-c New voice is on same staff. Set up for it
-c
- ivx = nv+1
- do 23 iiv = 1 , nv
- if (nvmx(iiv) .eq. 2) ivx = ivx+1
-23 continue
- if (ivx .gt. nm) then
- write(*,'(1x,a21,i3,a23)')'Cannot have more than',nm,
- * ' lines of music at once'
- call stop1()
- end if
- nvmx(iv) = 2
- ivmx(iv,2) = ivx
- itsofar(ivx) = 0
- nnl(ivx) = 0
- do 24 j = 1 , 200
- rest(ivx,j) = .false.
- nacc(ivx,j) = 0
-24 continue
-c
-c For midi stuff, record that there is a 2nd line of music in this voice
-c
- if (ismidi) twoline(iv) = .true.
- end if
- end if
- iccount = 128
- else if (charq .eq. 'S') then
-c
-c New nsyst: for use with partmaker scor2prt, for parts w/ diff # of systs.
-c
- if (ibarcnt .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"S" can only be in first input block!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('123456789 ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A digit must follow "S"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnsyst)
- nsyst = nint(fnsyst)
-14 continue
- if (durq .eq. 'P') then
-c
-c New npages for parts.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789 ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnsyst)
- npages = nint(fnsyst)
- go to 14
- else if (durq .eq. 'm') then
-c
-c Reset musize (musicsize).
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789 ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnsyst)
- musize = nint(fnsyst)
- wheadpt = whead20*musize
- go to 14
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in "S" symbol!')
- call stop1()
- end if
- else if (charq .eq. 'L') then
-c
-c Force line break
-c
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. 'C') then
-c
-c Coda, no real line break, just get coda length
-c
- if (ishort .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot use "LC" without first using "L[n]S"!')
- call stop1()
- end if
- ishort = 0
- call g1etchar(lineq,iccount,durq)
- if (index('1234567890.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Need number to define coda length!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,codafrac)
- poefa(isysflb(nflb)) = poefa(isysflb(nflb))+codafrac
- if (index(' n',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Need blank or "n" here!')
- call stop1()
- end if
- return
- end if
- nflb = nflb+1
- ibarflb(nflb) = ibarcnt+nbars+1
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Need integer to define forced line break!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,sysflb)
- isysflb(nflb) = nint(sysflb)
- if (isysflb(nflb) .eq. 1) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'For now, "L1" not allowed!')
- call stop1()
- end if
- if (nflb .gt. 1) then
-c
-c Check if new number is > prior one
-c
- if (isysflb(nflb) .le. isysflb(nflb-1)) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'You already forced a line break at a later line!')
- call stop1()
- end if
- end if
- if (npages .eq. 0) then
- print*
- print*,'WARNING! You forced a line break at line ',
- * isysflb(nflb),' but npage = 0. Continue?'
- read(*,'(a)') charq
- if (index('yY',charq) .eq. 0) call stop1()
- else if (isysflb(nflb) .gt. nsyst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Forced line break at line num > nsyst!')
- call stop1()
- else if (index(' PMS',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have " ", "P", "M", or "S" here!')
- call stop1()
- end if
-49 continue ! Transfer up from below to allow S after M
- if (durq .eq. 'S') then
-c
-c Shortened line, get shortening fraction
-c
- ishort = 1
- call g1etchar(lineq,iccount,durq)
- if (index('1234567890.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Need number to define line shortening fraction!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,shortfrac)
- poefa(isysflb(nflb)) = shortfrac
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Need blank here!')
- end if
- end if
- if (durq .eq. 'P') then
-c
-c Forced page break here, get page number.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Need integer to define forced page break!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- nfpb = nfpb+1
- ipagfpb(nfpb) = nint(fnum)
- isysfpb(nfpb) = isysflb(nflb)
- if (ipagfpb(nfpb) .gt. npages) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Forced page break at page num > npages!')
- call stop1()
- else if (nfpb .gt. 1) then
- if (ipagfpb(nfpb) .le. (ipagfpb(nfpb-1))) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Forced page break numbers must increase!')
- call stop1()
- end if
- end if
- end if
- if (index(' M',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in linebreak symbol!')
- call stop1()
- else if (durq .eq. 'M') then
- nmovbrk = nmovbrk+1
- isysmb(nmovbrk) = isysflb(nflb)
- call g1etchar(lineq,iccount,durq)
-31 if (durq .eq. '+') then
-c
-c Vertical spacing, read past number.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Integer required here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- go to 31
- else if (durq .eq. 'i') then
-c
-c Change indentation,
-c
- call g1etchar(lineq,iccount,durq)
- if (index('.123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Decimal number required here!')
- call stop1()
- end if
-c
-c fracsys was initialized in block data to all 0.'s
-c
- call readnum(lineq,iccount,durq,fracsys(nmovbrk))
- go to 31
- else if (durq .eq. 'c') then
- call g1etchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'r') then
- call g1etchar(lineq,iccount,durq)
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have "+" or "-" after "r" as movement break option!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'n') then
-c
-c Change # of voices. Input ninow, iorig(1...ninow). Will use names,
-c staves per inst. and clefs corr. to iorig in original list of instruments.
-c
- nv = 0
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. ':') then
-c
-c Signals a 2-digit number, get next two characters
-c
- call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,dumq)
- if (index('12',durq).eq.0
- * .or.index('0123456789',dumq).eq.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal new number of instruments '//durq//dumq//
- * ' at movement break!')
- call stop1()
- end if
- read(lineq(iccount-1:iccount),'(i2)')ninow
- else
-c
-c durq is a single digit number for noinow
-c
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal new number of instruments '//durq//
- * ' at movement break!')
- call stop1()
- end if
- ninow = ichar(durq)-48
- end if
- if (ninow.gt.noinst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'New number of instruments must be <= original!')
- call stop1()
- end if
- do 63 iinow = 1 , ninow
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. ':') then
-c
-c Signals a 2-digit number
-c
- call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,dumq)
- if (index('12',durq).eq.0
- * .or.index('0123456789',dumq).eq.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal 2-digit instrument number '//durq//dumq//
- * ' at movement break!')
- call stop1()
- end if
- read(lineq(iccount-1:iccount),'(i2)')iorig
- else
-c
-c durq is a single digit number for iorig
-c
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal instrument number '//durq//
- * ' at movement break!')
- call stop1()
- end if
- iorig = ichar(durq)-48
- end if
- if (iorig .gt. noinst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'New instrument number must be <= original noinst!')
- call stop1()
- end if
- nv = nv+nsperi(iorig)
-63 continue
- do 61 iiv = 1 , nv
-c
-c Get clef names
-c
- call g1etchar(lineq,iccount,durq)
- if (.not.(index('tsmanrbf',durq).gt.0 .or.
-c * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then
- * (ichar(durq).ge.48 .and. ichar(durq).le.56))) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have t,s,m,a,n,r,b,f or 1-7 as clef symbol here!')
- call stop1()
- end if
-c
-c Initialize new voices
-c
- nvmx(iiv) = 1
- ivmx(iiv,1) = iiv
- itsofar(iiv) = 0
- nnl(iiv) = 0
- do 62 j = 1 , 200
- rest(iiv,j) = .false.
-62 continue
-61 continue
-c
-c Loop back up, this might not be last option in M
-c
- call g1etchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'S') then
- go to 49
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after Movement break symbol!')
- call stop1()
- end if
- if (fracsys(nmovbrk) .lt. 0.001) then
-c
-c Since fracsys was not explicitly set, set it to prior value.
-c
- if (nmovbrk .eq. 1) then
- fracsys(nmovbrk) = fracindent
- else
- fracsys(nmovbrk) = fracsys(nmovbrk-1)
- end if
- end if
- end if
-c
-c Just before exiting if-block for forced line breaks, set counter to use when
-c dealing with vertical space calcs
-c
- nistaff(nflb) = nv-1
- else if (charq .eq. 'F') then
- usefig = .false.
- else if (charq .eq. 'X') then
- call g1etx(lineq,iccount,shifton,ibarcnt-ibaroff+nbars+1,
- * udsp(ibarcnt+nbars+1),wheadpt)
- else if (charq .eq. 'I') then
-c
-c MIDI settings.
-c
- if (ivx.ne.1 .or. nnl(1).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'MIDI stuff only allowed at start of block!')
- call stop1()
- end if
- if (nv .gt. 15) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Sorry but MIDI does not work with more than 15 voices!')
- call stop1()
- end if
- ismidi = .true.
- call getmidi(noinst,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar,
- * mtrdenl,nv,.true.)
- else if (charq .eq. 'M') then
- call setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,ivx,
- * nline)
- else if (index(',.',charq) .gt. 0) then
-c
-c Continued rhythmic shortcut
-c
- idotform = index('. ,',charq)
- if (idotform .eq. 1) then
-c
-c Change duration of prior note
-c
- itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx))
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- end if
- idotform = idotform+1
- numnum = 1
- cdot = .true.
- go to 1
- else
- print*,'ASCII code:',ichar(charq)
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character is not allowed here!')
- print*,'ASCII code:',ichar(charq)
- call stop1()
- end if
- return
- end
- subroutine g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
- * xmtrnum0,newkey,npages,nsyst,musize,bottreb)
- parameter(nm=24,maxblks=9600)
- character*131072 bufq
- character*1 chax
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- character*128 lineq
- logical lastchar,issegno,isheadr,isvolt,fbon,bottreb,
- * newway
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- common /commidisig/ midisig
-c
-c Get the first line
-c
- iccount = 0
- nline = 1
-9 call getbuf(lineq)
- if (lineq(1:1) .eq. '%') then
- nline = nline+1
- go to 9
- end if
- if (lineq(1:3) .eq. '---') then
-c
-c Have TeX input until next line that starts with '---'
-c
-3 nline = nline+1
- call getbuf(lineq)
- if (ilbuf .gt. nlbuf) go to 1
- go to 2
-1 print*,'You did not terminate type 0 TeX input with "---"'
- call stop1()
-2 continue
- if (lineq(1:3) .ne. '---') go to 3
-c
-c Force a new line read on first call to readin
-c
- iccount = 128
- end if
-c
-c Here, lineq and nline are first non-TeX lines.
-c
- nv = nint(readin(lineq,iccount,nline))
- if (nv .gt. nm) then
- write(*,'(1x,a46,i3)')
- * 'In setup data, number of voices cannot exceed',nm
- call stop1()
- end if
- noinst = nint(readin(lineq,iccount,nline))
- if (noinst .gt. nv) then
- write(*,'(a)')
- * 'In setup data, cannot have more instruments than staves'
- call stop1()
- end if
- newway = noinst.le.0
- if (newway) noinst = -noinst
- do 10 iinst = 1 , noinst
-c
-c Seve # of staves per inst in case later drop some inst's.
-c
- if (newway) then
- nsperi(iinst) = nint(readin(lineq,iccount,nline))
- else if (iinst .gt. 1 ) then
- nsperi(iinst) = 1
- else
- nsperi(iinst) = nv-noinst+1
- end if
-10 continue
- mtrnuml = nint(readin(lineq,iccount,nline))
- mtrdenl = nint(readin(lineq,iccount,nline))
-cc
-cc Kluge!!!
-cc
-c if (mtrdenl .eq. 1) then
-c mtrdenl = 2
-c mtrnuml = mtrnuml*2
-c end if
- mtrnmp = nint(readin(lineq,iccount,nline))
- mtrdnp = nint(readin(lineq,iccount,nline))
- if (mtrnmp.eq.0 .and. mtrdnp .ge. 8) then
- write(*,'(a)')'In setup data, with mtrnmp=0, mtrdnp must be <8'
- call stop1()
- end if
- xmtrnum0 = readin(lineq,iccount,nline)
- newkey = nint(readin(lineq,iccount,nline))
-c 130316
-c do 11 iinst = 1 , noinst
- midisig = newkey
-c11 continue
- npages = nint(readin(lineq,iccount,nline))
- nsyst = nint(readin(lineq,iccount,nline))
- musize = nint(readin(lineq,iccount,nline))
- fracindent = readin(lineq,iccount,nline)
- if (fracindent .ge. 1.) then
- write(*,'(a)')'In setup data, fracindent must be <1'
- call stop1()
- end if
- if (npages .gt. nsyst) then
- print*,'Error in input file: npages > nsyst'
- call stop1()
- else if((musize-16)*(musize-20)*(musize-24)*(musize-29).ne.0) then
- call printl('Musicsize must be 16, 20, 24, or 29')
- call stop1()
- end if
-c
-c Next noinst non-comment lines are names of instruments.
-c
- do 4 i = 1 , abs(noinst)
-5 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 5
-4 continue
-c
-c Mext non-comment line has nv clef names
-c
-6 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 6
- do 7 iv = 1 , nv
-c if (index('brnamstf01234567',lineq(iv:iv)) .eq. 0) then
- if (index('brnamstf012345678',lineq(iv:iv)) .eq. 0) then
- call errmsg(lineq,iv,0,
- * 'There should be a clef symbol here!')
- call stop1()
- end if
-7 continue
- if (lineq(nv+1:nv+1) .ne. ' ') then
- call errmsg(lineq,nv+1,0,
- * 'There should be a blank here!')
- call stop1()
- end if
-c
-c Set flag if voice 1 is treble, since it affects vertical spacing
-c
-c bottreb = lineq(1:1).eq.'t'
- bottreb = index('t08',lineq(1:1)).gt.0
-c
-c Next non-comment line has path name
-c
-8 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 8
- lpath = index(lineq,' ')-1
- if (index('/:'//chax(92),lineq(lpath:lpath)) .eq. 0) then
- call errmsg(lineq,lpath,0,
- * 'Last character of pathname is not "/",":", or "'
- * //chax(92)//'"!')
- call stop1()
- end if
- return
- end
- subroutine g1etx(lineq,iccount,shifton,ibar,udsp,wheadpt)
-c
-c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol.
-c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols.
-c
- logical shifton,number,btest
- character*128 lineq
- character*1 charq,dumq
- number = .false.
- nPBSc = 0
-1 call g1etchar(lineq,iccount,charq)
- if (index('PBS:',charq) .gt. 0) then
-c
-c Continue checking here even if "P".
-c
- ipbsc = index('PBS:',charq)
- if (btest(nPBSc,ipbsc)) then
- call errmsg(lineq,iccount,ibar,'Only one allowed per symbol!')
- call stop1()
- end if
- nPBSc = ibset(nPBSc,ipbsc)
- go to 1
- else if (index('+-.0123456789',charq) .gt. 0) then
- number = .true.
- if (index('+-',charq) .gt. 0) then
- call g1etchar(lineq,iccount,dumq)
- if (index('.0123456789',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibar,'Expected a number here!')
- call stop1()
- end if
- end if
- call readnum(lineq,iccount,dumq,fnum)
- if (charq.eq.'-') fnum = -fnum
- if (dumq .ne. 'p') then
- iccount = iccount-1
- fnum = fnum*wheadpt
- end if
- go to 1
- else if (charq .ne. ' ') then
- call errmsg(lineq,iccount,ibar,'Not allowed in "X" symbol!')
- call stop1()
- end if
-c
-c Done with parsing. Other checks
-c
- if (iand(6,nPBSc).eq.6 .or. iand(24,nPBSc).eq.24) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Cannot have both "P" and "B" or "S" and ":"!')
- call stop1()
- end if
- if (btest(nPBSc,4)) then
- if (number) then
- if (shifton) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Started a group shift without stopping prior one!')
- call stop1()
- else
- shifton = .true.
- end if
- else
- if (.not. shifton) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Ended a group shift without starting one!')
- call stop1()
- else
- shifton = .false.
- end if
- end if
- end if
-c
-c P off, S off, c off => normal user-defined space. Add to udsp (later fsyst)
-c
- if (iand(nPBSc,26).eq.0) udsp = udsp+fnum
- if (.not.number .and. .not.btest(nPBSc,4)) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Must have either a number or a colon in "X" symbol!')
- call stop1()
- end if
- return
- end
-c integer*4 function mytime()
-c CHARACTER(10) tq
-c CALL DATE_AND_TIME(TIME=tq)
-c read(tq,'(2i2,f6.3)')ih,im,ts
-c mytime = 1000*(ts+60*(im+60*ih))
-c return
-c end
- subroutine getbuf(lineq)
- parameter (maxblks=9600)
- character*(*) lineq
- character*131072 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- lineq = bufq(ipbuf+1:ipbuf+lbuf(ilbuf))
- ipbuf = ipbuf+lbuf(ilbuf)
- ilbuf = ilbuf+1
- return
- end
- subroutine getchar(lineq,iccount,charq)
- parameter (nm=24)
-c
-c Gets the next character out of lineq*128. If pointer iccount=128 on entry,
-c then reads in a new line. Resets iccount. Ends program if no more input.
-c
- common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS,
- * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
- * rptprev,equalize,rptfq1,rptfq2
- logical lastchar,rptnd1,sluron,fbon,rptprev,ornrpt
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac,equalize,stickyS
- character*1 charq,rptfq1,rptfq2
- character*128 lineq,lnholdq
- if (iccount .eq. 128) then
- call read10(lineq,lastchar)
- if (lastchar) return
- if (.not. endmac) then
- iccount = 0
- else
- endmac = .false.
- iccount = icchold
- lineq = lnholdq
- end if
- if (mrecord) then
- call mrec1(lineq,iccount,ndxm)
- end if
- end if
- iccount = iccount+1
- charq = lineq(iccount:iccount)
- return
- end
- subroutine getdyn(ivx,ip,irest,iornq,lineq,iccount)
- parameter (nm=24)
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical fontslur,upslur,WrotePsslurDefaults
- character*1 durq,chax
- character*4 dynsymq
- character*128 lineq
-c
-c Get info for dynamic mark. Enter after getting "D", iccount sits on "D"
-c Bits in idyndat are as follows
-c 00-03 ivx
-c 04-11 ip
-c 12-15 code for type of mark
-c 0 => arbitrary text
-c 1-12 => pppp,ppp,pp,p,mp,mf,f,fp,sfz,ff,fff,ffff
-c If (.not. fontslur)
-c 13 => hairpin start, 14,15 => <,> (ending)
-c else
-c 13 < start, 14 > start, 15 ending
-c end if
-c 16 flag for vertical offset
-c 17-23 vertical offset + 64 , \internote
-c 31 Hairpin start (0), stop (1)
-c
-c idynda2
-c
-c 00 flag for horizontal offset
-c 01-09 (horizontal offset)/10 + 25.6 notehead widths
-c 10 5th bit for ivx (5/15/10)
-c
- irest = ibset(irest,26)
- ndyn = ndyn+1
- idyn = ivx
- idynda2(ndyn) = 0
- if (ivx .ge. 16) call setbits(idynda2(ndyn),1,10,1)
- call setbits(idyn,8,4,ip)
- if (lineq(iccount+1:iccount+1) .eq. '"') then
-c
-c text-dynamic
-c
- ntxtdyn = ntxtdyn+1
- iccountt = iccount
-3 continue
- iend = iccountt+index(lineq(iccountt+2:128),'"')+2
- if (lineq(iend-2:iend-2) .eq. '\') then
- iccountt = iend-2
- go to 3
- end if
- txtdynq(ntxtdyn) = lineq(iccount+2:iend-2)
-c
-c Store ivx, ip in bits 0-12
-c
- ivxiptxt(ntxtdyn) = ivx+32*ip
- ipm = index('- +',lineq(iend:iend))
- idno = 0
- else
-c
-c Word-group or hairpin
-c
- do 1 iend = iccount+2 , 128
- ipm = index('- +',lineq(iend:iend))
-c
-c Exit the loop at first blank, "+", or "-"
-c
- if (ipm .gt. 0) go to 2
-1 continue
-2 continue
- read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')')
- * dynsymq
- idno = (index(
- * 'ppppppp pp p mp mf f fp sfz ff fff ffff < > ',
- * dynsymq)+3)/4
-c
-c Save for later down
-c
- idno1 = idno
- end if
-c
-c Set flag to check level later if in beam
-c
- iornq = ibset(iornq,23)
- if (idno.ge.14) then
-c
-c Hairpin here. Check if opposite type from one that's already on
-c
- if (idno.eq.14.and.btest(listdecresc,ivx) .or.
- * idno.eq.15.and.btest(listcresc,ivx)) then
- call printl(' ')
- call printl('Started one kind of hairpin while other is on')
- call stop1()
- end if
-c
-c Start or stop?
-c
- if (btest(listcresc,ivx) .or. btest(listdecresc,ivx)) then
-c
-c Cresc/decresc is on, this is an ending. If fontslur, leave idno as is.
-c
- if (.not.fontslur) idno = 15
- else if (fontslur) then
-c
-c Start of font slur
-c
- idno = 13
- else
-c
-c Start of postscript slur
-c
- idno = idno-1
- end if
- end if
-c
-c Now that we used list[de]cresc, update
-c
- if (idno .ge.13) then
- if (idno.eq.15 .or. (fontslur.and.idno.eq.14)) then
-c
-c Something's ending
-c
- if (btest(listcresc,ivx)) then
-c
-c It's a cresc!
-c
- listcresc = ibclr(listcresc,ivx)
- else
- listdecresc = ibclr(listdecresc,ivx)
- end if
- else
-c
-c Something's starting
-c
- if (idno1 .eq. 14) then
-c
-c It's a cresc!
-c
- listcresc = ibset(listcresc,ivx)
- else
- listdecresc = ibset(listdecresc,ivx)
- end if
- end if
- end if
- call setbits(idyn,4,12,idno)
- iccount = iend
- if (ipm .ne. 2) then
-c
-c There is a vertical shift
-c
- idyn = ibset(idyn,16)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(fnum)
- call setbits(idyn,7,17,(ipm-2)*idno+64)
- ipm = index('- +',durq)
- if (ipm .ne. 2) then
-c
-c There is a horizontal shift
-c
-c idynda2(ndyn) = ibset(idyn,23)
- idynda2(ndyn) = ibset(idynda2(ndyn),0)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(10*fnum)
- call setbits(idynda2(ndyn),9,1,(ipm-2)*idno+256)
- end if
-c
-c iccount should be on the blank at the end of the entire symbol
-c
- end if
- idyndat(ndyn) = idyn
- return
- end
- subroutine getfig(itoff,charq,lineq,iccount,isfig,itfig,
-c * itsofar,nodur,figq,ivupfig,nfigs)
- * itsofar,nodur,figq,ivupfig,ivvfig,nfigs)
- logical isfig
- character*1 charq
- character*10 figq
- character*128 lineq
- nfigs = nfigs+1
- ivupfig = 0
- ivvfig = 0
- itoff = 0
- if (charq .eq. 'x') then
-c
-c Floating figure.
-c
- call getchar(lineq,iccount,charq)
- read(charq,'(i1)')noff
- call getchar(lineq,iccount,charq)
- read(charq,'(i1)')loff
- itoff = noff*ifnodur(loff,'x')
- call getchar(lineq,iccount,charq)
- else
-c
-c Figure on a note
-c
- isfig = .true.
- end if
- itfig = itsofar+itoff-nodur
- lfig = 1
- figq = charq
-5 call getchar(lineq,iccount,charq)
-c if (index(' +',charq) .eq. 0) then
- if (index(' +v',charq) .eq. 0) then
- figq = figq(1:lfig)//charq
- lfig = lfig+1
- go to 5
- else if (charq .eq. '+') then
-c
-c Get vertical offset for figure. Next character after number has to be blank.
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- ivupfig = nint(fnum)
- else if (charq .eq. 'v') then
-c
-c Get vertical change in figdrop. Must be last item in figure word.
-c
- isign = 1
- call getchar(lineq,iccount,charq)
- if (charq .eq. '-') then
- isign=-1
- call getchar(lineq,iccount,charq)
- end if
- ivvfig = isign*(ichar(charq)-48)
- end if
- return
- end
- subroutine getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev,
- * lastlev,iv,nv)
- parameter (nm=24)
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg
- character*1 charq,durq
- character*20 voltxtq
- character*128 lineq,litq
- integer*4 islur(nm,200),iornq(nm,0:200),ipl(nm,200),nnl(nm),
- * ndlev(nm,2)
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
-c
-c Grace, comes *before* main note:
-c UNLESS there's an 'A' or 'W' after the 'G'
-c ngrace = # of grace note groups so far in block
-c ivg(ngrace), ipg(ngrace)
-c nng(ngrace) = # of notes in this group: default = 1
-c ngstrt(ngrace) = starting position in nolevg of levels for this grace
-c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)'
-c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l'
-c slurg(ngrace) = logical for slur; default F, input 's'
-c slashg(ngrace) = T if slash; default is F, input 'x'
-c These data MUST precede note name of first note
-c nolevg, naccg: lists of levels and accid's, indexed as described above.
-c
- ngrace = ngrace+1
- ivg(ngrace) = ivx
- ipg(ngrace) = nnl(ivx)+1
- if (ngrace .eq. 1) then
- ngstrt(ngrace) = 1
- else
- ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1)
- end if
- islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4)
- nng(ngrace) = 1
- multg(ngrace) = 1
- upg(ngrace) = .true.
- slurg(ngrace) = .false.
- slashg(ngrace) = .false.
-18 call getchar(lineq,iccount,charq)
- if (index('WA',charq) .gt. 0) then
-c
-c Grace is on note that was already done, so shift flags forward one note.
-c This puts flag on actual note with grace; later for W will go ahead one more.
-c
- ipg(ngrace) = nnl(ivx)
- islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4)
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4)
- if (slurg(ngrace))
- * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24)
- if (charq .eq. 'A') then
-c
-c close After, clear way-after bit, to ensure priority of most recent A/W
-c
- ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29)
- else
-c
-c Way after; later assign to following note, and position like normal grace.
-c
- ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31)
- end if
- else if (charq .eq. 'm') then
- call getchar(lineq,iccount,charq)
- multg(ngrace) = ichar(charq)-48
- else if (index('123456789',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- nng(ngrace) = nint(fnum)
- else if (charq .eq. 'l') then
- upg(ngrace) = .false.
- else if (charq .eq. 's') then
- slurg(ngrace) = .true.
- if (nnl(ivx) .gt. 0) then
-c
-c If A- or W-grace, set signal to start slur on main note.
-c
- if(btest(ipl(ivx,nnl(ivx)),31) .or.
- * btest(ipl(ivx,nnl(ivx)),29))
- * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24)
- end if
- else if (charq .eq. 'x') then
- slashg(ngrace) = .true.
- else if (charq .eq. 'u') then
- else if (charq .eq. 'X') then
-c
-c Space before main note of grace. Number will come next.
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,graspace(ngrace))
- iccount = iccount-1
- end if
- if (index('abcdefg',charq) .eq. 0) go to 18
-c
-c At this point, charq is first note name in grace
-c
- do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1
- naccg(ing) = 0
- ioct = 0
- if (ing .gt. ngstrt(ngrace)) then
-55 call getchar(lineq,iccount,charq)
- if (charq .eq. ' ') go to 55
- endif
- iclastlev = 0
-9 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
- if (durq.eq.'+') then
- lastlev = lastlev+7
- iclastlev = iclastlev+7
- else if (durq.eq.'-') then
- lastlev = lastlev-7
- iclastlev = iclastlev-7
- else if (index('fsn',durq) .gt. 0) then
- if (naccg(ing) .eq. 0) then
- naccg(ing) = index('fsn',durq)
- else
-c
-c Double accidental
-c
- naccg(ing) = ibset(naccg(ing),2)
- end if
- else
- ioct = ichar(durq)-48
- end if
- go to 9
- end if
- if (ioct .gt. 0) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- else
- if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- lastlev = ndlev(iv,kv)+iclastlev
- end if
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- end if
- nolevg(ing) = lastlev
-19 continue
-c
-c Grace could come before first note of block, so reset end level.
-c
- if (nnl(ivx).eq.0) then
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- ndlev(iv,kv) = lastlev
- end if
- return
- end
- subroutine GetiTransInfo(From1,ibarcnt,lineq,iccount,
- * ibaroff,nbars,noinst)
-cccccccccccccccccccccccc
-cc
-cc GetiTransInfo.for
-cc
-cccccccccccccccccccccccc
-c
-c Called from both g1etnote and getnote, after first 'i' in Ki[...]
-c On entry, iccount points to last char retrieved, which is 'i'
-c
-c From1: locgical, true if called from g1etnote
-c ibarcnt: tells whether to set EarlyTransOn to true.
-c EarlyTransOn set false in blkdata, true here, back to false in topfile.
-c
-c 110522/110529
-c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey]
-c and repeat i[...] for multiple instruments. Store info in g1etnot if ibarcnt=0
-c so can pass to topfile (via comInstTrans), which is called before getnote.
-c Otherwise, will store info from getnote. Initialize EarlyTransOn and
-c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from g1etnote;
-c LaterInstTrans from getnote. Zero both out after use. nInstTrans really
-c only needed for instrument-signatures, not transpositions. iTransAmt is
-c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for
-c each staff.
-c
-c iTransAmt stored as fn of instrument #, not like iTransKey which is
-c fn. of nm, just a counter, where corr. inst num is iInstTrans(nm). This
-c simplifies use of iTransAmt for all calls to ifnolev.
-c
- parameter (nm=24)
- logical From1
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans,store
- character*128 lineq
- character*1 durq
- durq = 'x' ! Can't initialize in declaration stmt, only works once.
- if(.not.EarlyTransOn) EarlyTransOn = From1 .and. ibarcnt.eq.0
- store = (EarlyTransOn.and.ibarcnt.eq.0) .or.
- * (ibarcnt.gt.0.and..not.From1)
- LaterInstTrans = .not.From1 .and. ibarcnt.gt.0
- if (store) nInstTrans = 0
-1 continue
- if (durq .eq. ' ') return
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be an instrument number here!')
- call stop1()
- end if
- if (store) nInstTrans = nInstTrans+1
- call readnum(lineq,iccount,durq,fnum)
- instn = nint(fnum)
- if (instn.gt.noinst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Instrument number out of range!')
- call stop1()
- end if
- if (store) iInstTrans(nInstTrans) = instn
-c
-c durq is +/- following inst # (for iTransAmt), iccount is on it.
-c
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st character after instrument number must be "+,-"!')
- call stop1()
- end if
- itramt = 44-ichar(durq) ! +1/-1 for itramt
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a transposition amount here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (store) iTransAmt(instn) = nint(fnum)*itramt
-c
-c durq is +/- following iTransAmt (for iTransKey), iccount is on it.
-c
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st character after transposition amount must be "+,-"!')
- call stop1()
- end if
- ikey = 44-ichar(durq) ! +1/-1
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a key indicator here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (store) iTransKey(nInstTrans) = nint(fnum)*ikey
-c
-c durq is now 1st character after iTransKey, should be either 'i' or ' '
-c
- if (durq.ne.'i'.and.durq.ne.' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be blank or "i" here!')
- call stop1()
- end if
- go to 1
- end
- subroutine getmidi(noinstarg,lineq,iccount,ibarcnt,ibaroff,nbars,
- * lenbar,mtrdenl,nv,first)
-c
-c Use this from both pmxa and pmxb to input and check midi data. "first" tells
-c whether pmxa or pmxb. If .not.first, then tempo and pause commands cause
-c things to be written immediately into the midi storage buffers.
-c
- parameter (nm=24,mv=24576)
- common /comevent/ miditime,lasttime
- logical mmacrec,gottempo
- common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
- * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60),
- * mmacrec,gottempo
-c
-c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing
-c nmidsec section starts and stops based on PLAYING macros (not recording).
-c
- integer*2 mmidi,midinum(26)
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm),noinstdum,iinsiv(nm)
- integer*2 iinsiv
- character*1 durq
- character*2 instq
- character*128 lineq
- logical first
- common /comdiag/ n69(0:nm),n34(0:nm)
-c
-c Instrument codes
-c
- data midinum
- * / 1, 5, 7, 13,20,25,33,41,42,43,44,57,58,59,61,65,66,67,
-c XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbXtuXfrXsoXalXteX
-c
- * 68,69,71,72,74,75, 8,55 /
-c bsXobXbaXclXflXreXctXvo
-c
-1 call getchar(lineq,iccount,durq)
- if (durq .eq. 't') then
-c
-c Tempo in beats ber minute
-c
- call getchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected an integer here for the pause!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,qpm)
- iccount = iccount-1
- if (.not.first) then
- call midievent('t',nint(qpm),0)
- gottempo = .true.
- end if
- go to 1
- else if (durq .eq. 'p') then
-c
-c Insert a pause. pausemid = pause in 1/4's
-c
- call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number here for the pause!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,pausemid)
- iccount = iccount-1
- if (.not.first) then
-c
-c Compute a meter for the pause. This is only to keep MidiNotate on track.
-c Round pause to nearest 16th. Let denominator always be 16.
-c
- numb16 = nint(pausemid*4)
- call midievent('m',numb16,16)
-c
-c Put in pausemid beats of rest
-c
- do 3 icm = 0 , numchan-1
- call addmidi(icm,0,0,0,4.*numb16,.true.,.false.)
-3 continue
- miditime = miditime+nint(240*pausemid)
-c
-c Restore meter
-c
- call midievent('m',mtrdenl*lenbar/64,mtrdenl)
- end if
- go to 1
- else if (durq .eq. 'i') then
-c
-c Instrument numbers or letters. Expect noinst of them.
-c
- do 2 ivx = 1 , noinstarg
- call getchar(lineq,iccount,durq)
- if (ichar(durq) .gt. 96) then
-c
-c It's a lowercase letter. Get another, find corr. instrument #.
-c
- instq(1:1) = durq
- call getchar(lineq,iccount,durq)
- instq = instq(1:1)//durq
- iname = index('XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbX'//
- * 'tuXfrXsoXalXteXbsXobXbaXclXflXreXctXvo',instq)/3
- if (iname .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Unrecognized 2-letter midi instrument name!')
- call stop1()
- end if
- midinst(ivx) = midinum(iname)-1
- else
-c
-c Expect a number, followed by ":" if that is followed by another number.
-c I.e., if after call to readnum, durq is not ":", it must be either blank
-c or next instrument letter.
-c
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a midi instrument number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- midinst(ivx) = nint(fnum)-1
- if (midinst(ivx).lt.0 .or. midinst(ivx).gt.255) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Midi instrument number must be in range 1-128!')
- call stop1()
- end if
- if (durq .ne. ':') iccount = iccount-1
- end if
-2 continue
- go to 1
- else if (durq .eq. 'v') then
-c
-c Get volumes for each instrument. Expect noinst of them.
-c Follow same pattern as for insttrument numbers above.
-c
- do 7 ivx = 1 , noinstarg
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a midi velocity number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- midivel(ivx) = nint(fnum)-1
- if (midivel(ivx).lt.0 .or. midivel(ivx).gt.127) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Midi velocity must be in range 1-128!')
- call stop1()
- end if
- if (durq .ne. ':') iccount = iccount-1
-7 continue
- if (.not. first) then
- call inst2chan(midvelc,midivel,midchan,nv,iinsiv,twoline)
- end if
- go to 1
- else if (durq .eq. 'b') then
-c
-c Get balance for each instrument. Expect noinst of them.
-c Follow same pattern as for instrument numbers above.
-c
- do 8 ivx = 1 , noinstarg
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a balance number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- midibal(ivx) = nint(fnum)-1
- if (midibal(ivx).lt.0 .or. midibal(ivx).gt.127) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Midi balance must be in range 1-128!')
- call stop1()
- end if
- if (durq .ne. ':') iccount = iccount-1
-8 continue
- if (.not. first) then
- call inst2chan(midbc,midibal,midchan,nv,iinsiv,twoline)
- end if
- go to 1
- else if (durq .eq. 'T') then
-c
-c Get transposition for each instrument. Expect noinst of them.
-c Follow similar pattern as above, but separator is +|-.
-c
- do 9 ivx = 1 , noinstarg
- call getchar(lineq,iccount,durq)
- ipm = index('-+',durq)
- if (ipm .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "+" or "-" for midi transposition here!')
- call stop1()
- end if
- ipm = 2*ipm-3
- call getchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- miditran(ivx) = ipm*nint(fnum)
-c if (mod(miditran(ivx),12).ne. 0) then
-c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'Midi transposition limited to multiples of 12!')
-c call stop1()
-c end if
- iccount = iccount-1
-9 continue
- if (.not. first) then
- call inst2chan(midtc,miditran,midchan,nv,iinsiv,twoline)
- end if
- go to 1
- else if (durq .eq. 'g') then
- call getchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected an integer here for the midi gap!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- mgap = nint(fnum)
- iccount = iccount-1
- go to 1
- else if (durq .eq. 'M') then
-c
-c MidiMacros
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'R') then
-c
-c Start recording
-c
- if (mmacrec) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You tried to record a MidiMacro while already recording!')
- call stop1()
- end if
- mmacrec = .true.
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected MidiMacro ID number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- if (.not.first) then
- immac = nint(fnum)
- if (immac .gt. 20) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'MidiMacro ID cannot exceed 20!')
- call stop1()
- end if
-c
-c Save the start time
-c
- mmactime(immac) = miditime
- do 4 icm = 0 , numchan
- if (icm .lt. numchan) then
- if (restpend(icm)) then
-c
-c Adjust if there's a rest at end of prior section. Insert dummy turnoff.
-c (This causes two turn-offs in a row, which testmidi sees as an error).
-c
-c Before: section1 ------rest------- section2(to be recorded)
-c After: section1 rest1 now rest2 section2(recorded)
-c
- call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
- trest(icm) = 0
- restpend(icm) = .false.
- end if
- else
- if (miditime .gt. lasttime) then
-c
-c Insert a dummy turnoff in conductor track
-c
- call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
- * .false.,.true.)
- lasttime = miditime
- end if
- end if
- mmacstrt(icm,immac) = imidi(icm)+1
-4 continue
- end if
- go to 1
- else if (index('123456789P',durq) .eq. 0) then
-c
-c End recording; close the open macro. Get immac from common.
-c
- if (.not.mmacrec) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'You tried to end a MidiMacro before starting one!')
- call stop1()
- end if
- mmacrec = .false.
- iccount = iccount-1
- if (.not.first) then
-c
-c Save the macro duration
-c
- mmactime(immac) = miditime-mmactime(immac)
- do 5 icm = 0 , numchan
- if (icm .lt. numchan) then
- if (restpend(icm)) then
- call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
- trest(icm) = 0
- restpend(icm) = .false.
- end if
- else
- if (miditime .gt. lasttime) then
-c
-c Insert a dummy turnoff in conductor track if needed.
-c
- call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
- * .false.,.true.)
- lasttime = miditime
- end if
- end if
- mmacend(icm,immac) = imidi(icm)
-5 continue
- end if
- if (durq .ne. ' ')go to 1
- else if (durq .eq. 'P') then
-c
-c Play Back a Macro
-c
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected MidiMacro ID number here!')
- call stop1()
- end if
- if (mmacrec) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You tried to play a MidiMacro before ending recording!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- if (.not.first) then
- immac = nint(fnum)
- if (mmactime(immac) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot play a MIDI macro before recording it!')
- call stop1()
- end if
- do 6 icm = 0 , numchan
- if (icm .lt. numchan) then
- if (restpend(icm)) then
- call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
- trest(icm) = 0.
- restpend(icm) = .false.
- end if
- else
- if (miditime .gt. lasttime) then
-c
-c Insert a dummy turnoff in conductor track
-c
- call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
- * .false.,.true.)
- end if
- end if
- msecend(icm,nmidsec) = imidi(icm)
- msecstrt(icm,nmidsec+1) = mmacstrt(icm,immac)
- msecend(icm,nmidsec+1) = mmacend(icm,immac)
- msecstrt(icm,nmidsec+2) = imidi(icm)+1
-6 continue
- nmidsec = nmidsec+2
-c
-c Update running time
-c
- miditime = miditime+mmactime(immac)
- lasttime = miditime
- end if
- go to 1
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in MidiMacro sub-command!')
- call stop1()
- end if
- else if (durq .eq. 'd') then
- debugmidi = .true.
- go to 1
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in MIDI input data!')
- write(*,'(a)')
- * 'May be too many args to i,v,b, or T. As of Ver. 2.7, '//
- * 'should be noinst, not nv'
- write(15,'(a)')
- * 'May be too many args to i,v,b, or T. As of Ver. 2.7, '//
- * 'should be noinst, not nv'
- call stop1()
- end if
- if (.not.gottempo .and. .not.first) then
-c
-c If no tempo is set on first call on the pmxb pass, then set it
-c
- call midievent('t',96,0)
- gottempo = .true.
- end if
- return
- end
- subroutine getnote(loop)
- parameter (nm=24,mv=24576)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink,ignorenats,newmbrhgt
- common /comignorenats/ mbrhgt,newmbrhgt,ignorenats
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*10 figq
- character*1 ulq,sepsymq,sq,rptfq1,rptfq2,clefq,chax
- logical beamon,firstgulp,figbass,figchk,isfig
- character*60 cheadq
- character*120 instrq,titleq,compoq
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,autofbon
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2,multbj1
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /cominbot/ inbothd
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2,ivvfig(2,74)
- common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd,
- * npreslur,was2(nm),ninow,nobar1,nsystp(75),ipage,
- * OptLineBreakTies,HeaderSpecial
- common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS,
- * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
- * rptprev,equalize,rptfq1,rptfq2
- common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,fbon,ornrpt,shifton,setis,notcrd,isbjmp,
- * was2,nobar1,quoted,isbj2,stickyS,
- * OptLineBreakTies,HeaderSpecial
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- character*128 litq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * maxdotmv(nm),ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /combc/ bcspec
- common /comas3/ ask(2500),iask,topmods
-c
-c nvmx is either 1 or 2. ivmx(iv,1)=iv, ; ivmx(iv,2)>nv if defined
-c ivx is current ivmx, and is the index for all notes, acc's etc.
-c
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /comtrans/ cheadq
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig,
- * lnam(nm),inameq(nm)
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- common /comclefq/ clefq(nm)
- common /comtol/ tol
- common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20),
- * ArpShift(20)
- character*128 txtdynq
- logical mrecord,mplay,endmac,lowdot,rename,bar1syst,upslur,
- * fontslur,WrotePsslurDefaults
- character*128 lineq,lnholdq,lineqt
- character*80 headrq, lowerq
- character*79 inameq
- character*59 hdlndq
- character*20 voltxtq
- character*1 charq,dotq,durq,ulfbq,dumq
- logical loop,lastchar,lower,rptnd1,rptprev,bcspec,moved,
- * topmods,headlog,btest,sluron,cdot,equalize
- character*24 tempq
- logical novshrinktop,cstuplet
- common /comnvst/ novshrinktop,cstuplet
- logical kbdrests
- common /comkbdrests/ levbotr(8),levtopr(8),kbdrests
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idumm1,isig1,
- * mbrestsav,kchmid(18),logdumm1,logdumm2,barend,noinst,logdumm3
- logical barend,iskchb,kchmid,logdumm1,logdumm2,logdumm3
- common /combibarcnt/ ibarcnt
- common /commidisig/ midisig
- common /comlyr/ inputmlyr
- logical inputmlyr
- common /combottop/ botamt,topamt,bottopgap
- logical bottopgap
- logical inxtup
- common /comshort/ shortfrac,codafrac,ishort,mbrsum,nmbr,nocodabn,
- * poefa
- real*4 poefa(125)
- logical nocodabn
- cdot = .false.
- inxtup = .false.
-1 call getchar(lineq,iccount,charq)
- if (lastchar) return
- if (charq .eq. ' ') go to 1
- if (charq .eq. '%') then
-c
-c Check for a bar number format:
-c
- if (iccount.eq.1 .and. lineq(2:2).eq.' ' .and.
- * index('bB1234567890',lineq(3:3)).gt.0) then
- if (islast) write(11,'(a)')lineq(1:lenstr(lineq,128))
- end if
- iccount = 128
- go to 1
- end if
-c
-c Closing repeat iff charq='/' and the prev. char was 'R' with 'd' or 'r'
-c
- if (rptprev) then
- rptnd1 = charq .eq. '/'
- rptprev = .false.
- end if
-c
-c Repeat at end of a piece
-c
- if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or.
- * charq.eq.'r') then
- if (cdot) go to 28
-c
-c This is a note/rest.
-c
- idotform = 0
- numnum = 0
-c
-c If start of line of music, set pitch from previous
-c
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- if (nnl(ivx).eq.0) lastlev = ndlev(iv,kv)
-c
-c notcrd is used to tell if orn. goes on main note or chord note
-c
-c notcrd = .true. !Move dow. Was not observed if dotted shortcut.
-c
-c Increase note count, then loop 'til blank. Label 28 is for dotted shortcuts.
-c
-28 continue
-c
-c Moved this from just above, 2 Feb 02
-c
- notcrd = .true.
- nnl(ivx) = nnl(ivx)+1
- if (ornrpt) then
-c
-c Replicate ornament bits, also bit 23 for beam handling if chord.
-c
- iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),iornq(ivx,0))
- if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
-c
-c This is a trill (bit 7 or 15) so must dup the parameters
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = nnl(ivx)
- xnsktr(ntrill) = xnsktr(ntrill-1)
- end if
- end if
- if (stickyS) then
-c
-c Grab stemlength shortening parameters from prior note
-c
- mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27)
-c call setbits (mult(ivx,nnl(ivx)),3,28,
-c * igetbits(mult(ivx,nnl(ivx)-1),3,28))
- call setbits (mult(ivx,nnl(ivx)),6,10,
- * igetbits(mult(ivx,nnl(ivx)-1),6,10))
- end if
- if (autofbon .and. tautofb.gt.tol .and. .not.fbon) then
-c
-c Doing auto forced beams, and period has been set, so check if this note
-c starts a period.
-c
-c if (mod(1.*itsofar(ivx),tautofb) .lt. tol) then
- if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then
-c
-c Start a forced beam here
-c
- nfb(ivx) = nfb(ivx)+1
- fbon = .true.
- ulfbq(ivx,nfb(ivx)) = 'x'
- t1fb(ivx,nfb(ivx)) = itsofar(ivx)
- end if
- end if
- if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30)
- dotq = 'x'
- if (charq.eq.'r')
- * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0)
- if (btest(irest(ivx,nnl(ivx)),0)) then
-c
-c Rest stuff. First check if previous note was full-bar-pause
-c
- if (lineq(iccount+1:iccount+1) .eq.' '
- * .and. nnl(ivx).gt.1) then
- if (btest(islur(ivx,nnl(ivx)-1),19))
- * islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19)
- end if
-c
-c Set default rest level at 0 unless 2 voices/staff in which case it's -4 or 2
-c for voice a or b. Set a-types at 0 as encountered and adjust later
-c after '//'. (Override heights will be set to 100+offset)
-c
- if (ivx .le. nv) then
- nolev(ivx,nnl(ivx)) = 0
- else
- nolev(ivx,nnl(ivx)) = 2
- end if
- end if
-2 call getchar(lineq,iccount,durq)
- ic = ichar(durq)
- if (ic.le.57 .and. ic.ge.48) then
-c
-c Digit
-c
- if (numnum .eq. 0) then
- nnodur = ic-48
- numnum = 1
- go to 2
- else if (numnum .eq. 1) then
- ioct = ic-48
- numnum = 2
- go to 2
- else
- print*,'>2 digits in note sym., ivx,nn:',ivx,nnl(ivx)
- call stop1()
- end if
- else if (durq .eq. 'd') then
- dotq = durq
- if (lineq(iccount+1:iccount+1) .eq. 'd') then
-c
-c Double dot.
-c
- iccount = iccount+1
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),3)
- end if
- if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
-c
-c move a dot, unless next char is not part of a number
-c
- if (index('0123456789.',lineq(iccount+2:iccount+2)) .eq. 0)
- * go to 2
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),19)
- call getchar(lineq,iccount,durq)
- ndotmv(ivx) = ndotmv(ivx)+1
- iccount=iccount+1
- call readnum(lineq,iccount,dumq,updot(ivx,ndotmv(ivx)))
- if (durq .eq. '-')
- * updot(ivx,ndotmv(ivx)) = -updot(ivx,ndotmv(ivx))
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift also
-c
- iccount=iccount+1
- call readnum(lineq,iccount,durq,rtdot(ivx,ndotmv(ivx)))
- if (dumq .eq. '-')
- * rtdot(ivx,ndotmv(ivx)) = -rtdot(ivx,ndotmv(ivx))
- else
- rtdot(ivx,ndotmv(ivx)) = 0.
- end if
- iccount = iccount-1
- end if
- go to 2
- else if (durq .eq. 'p') then
-c
-c Full-bar rest as pause
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19)
- go to 2
- else if (durq .eq. 'b') then
-c
-c Blank rest
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29)
- go to 2
- else if (index('fsn',durq) .gt. 0) then
-c
-c Accidental
-c
-c if (nacc(ivx,nnl(ivx)) .eq. 0) then
-c 171209 May have set bit 18 earlier if D or F preceded accidental
- if (igetbits(nacc(ivx,nnl(ivx)),2,0) .eq. 0) then
-c
-c No accidental has been set yet
-c
-c nacc(ivx,nnl(ivx)) = index('fsn',durq)
- nacc(ivx,nnl(ivx)) =
- * ior(nacc(ivx,nnl(ivx)),index('fsn',durq))
- else
-c
-c Repeated accid, so must be double
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2)
- end if
- go to 2
- else if (durq .eq. 'i') then
-c
-c Set flag for MIDI-only accidental.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17)
- go to 2
- else if (durq .eq. 'c') then
-c
-c Set flags for cautionary accidental
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31)
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31)
- go to 2
- else if (index('+-<>',durq) .gt. 0) then
- ipm = index('- +',durq)-2
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
-c
-c A note, not a rest.
-c
- call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved)
- if (moved) go to 2
-c
-c Octave jump with a note
-c
- if (numnum .lt. 2) then
- lastlev = lastlev+ipm*7
- else
- ioct = ioct+ipm*1
- end if
- go to 2
- else
-c
-c Override default height of a rest
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (lineq(iccount-1:iccount-1) .eq. '.') then
-c
-c Kluge in case there is a shortcut ".". It will have been sucked up by
-c readnum. (Same doesn't hold for ",")
-c
- iccount = iccount-1
-c go to 2
- end if
- nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum)
-c
-c There may be more characters for this rest
-c
- iccount = iccount-1
- go to 2
- end if
- else if (durq .eq. 'x') then
-c
-c Xtuplet. Count number of doubled notes (for unequal xtups)
-c
- if (btest(nacc(ivx,nnl(ivx)),18)) then
- ndoub = 1
- else
- ndoub = 0
- end if
-c
-c Initialize counter for # of non-rests, so can later unbeam if = 1.
-c
- inxtup = .true.
- note1xtup = nnl(ivx)
- nnb = 0
- if (.not.btest(irest(ivx,nnl(ivx)),0)) nnb = 1
-c
-c Will set all durations to 0 except last one. Set flag on this note.
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),28)
-c
-c Next input will be digit unless its a "T"
-c
- iccount = iccount+1
- if (lineq(iccount:iccount) .eq. 'T') then
-c
-c Set up tremolo
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),2)
- ntup = 2
-c
-c Set default beaming, based on Wikipedia article
-c May be a problem here is nnodur is inherited
-c
- if (nnodur .eq. 4) then
- nsolid = 0
- nindent = 3
- else if (nnodur .eq. 2) then
- nsolid = 3
- nindent = 0
- else if (nnodur .eq. 8) then
- nsolid = 1
- nindent = 2
- end if
- call getchar(lineq,iccount,durq)
- if (index('0123456789',durq) .gt. 0) then
- nsolid = index('0123456789',durq)-1
- if (nsolid.eq.0 .and. nnodur.eq.2) then
- print*,''
- print*,'Unbeamed half-note 2-note tremolo forbidden.'
- call stop1()
- end if
- call getchar(lineq,iccount,durq)
- if (index('0123456789',durq) .gt. 0) then
- nindent = index('0123456789',durq)-1
- end if
- end if
- call setbits(irest(ivx,nnl(ivx)),2,3,nsolid)
- call setbits(irest(ivx,nnl(ivx)),2,5,nindent)
- if (nsolid .eq. 0) then
- islur(ivx,nnl(ivx)) =
- * ibset(islur(ivx,nnl(ivx)),18)
- end if
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),31)
- islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),21)
- call setbits(islur(ivx,nnl(ivx)+1),3,22,nsolid)
-c
-c Set some force-beam parameters for the tremolo
-c
-c Need to check if there's already a forced beam explicitly set here.
-c If there was, shouldn't do any harm resetting parameters.
-c
- if (nfb(ivx).eq.0 .or. t1fb(ivx,nfb(ivx)).ne.itsofar(ivx))
- * nfb(ivx) = nfb(ivx)+1
- fbon = .true.
- ulfbq(ivx,nfb(ivx)) = 'x'
- t1fb(ivx,nfb(ivx)) = itsofar(ivx)
- t2fb(ivx,nfb(ivx)) = itsofar(ivx) + ifnodur(nnodur,dotq)
- nadj = 0
-c
-c Set open beamed notehead flag for half-note tremolo
-c Just gave 2 quarters with or without flag set. Need to fix
-c
- else
- call readnum(lineq,iccount,durq,fnum)
- ntup = nint(fnum)
- end if
- if (index('DF',durq) .gt. 0) then
-c
-c
-c Double xtup note to make an un= xtup. Here xtup number already set but may also
-c have this command before.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- if (durq .eq. 'F') nacc(ivx,nnl(ivx)) =
- * ibset(nacc(ivx,nnl(ivx)),19)
- ndoub = 1
- call getchar(lineq,iccount,durq)
- else if (durq .eq. 'd') then
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- call getchar(lineq,iccount,durq)
- end if
-c
-c Only other possibilities here are ' ' or 'n'
-c
- if (durq .eq. 'n') then
-c
-c Alter xtup number
-c
- if (lineq(iccount+1:iccount+1) .eq. ' ') then
-c
-c If the only modifier is 'n', cancel the number
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),31)
- else
- numshft = 0
-30 call getchar(lineq,iccount,durq)
- if (durq .eq. 'f') then
-c
-c Flip up-down-ness
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),14)
- go to 30
- else if (index('+-',durq) .gt. 0) then
-c
-c Vertical or horiz shift
-c
- numshft = numshft+1
- iofforn = 1
- if (durq .eq. '-') iofforn = -1
- iccount = iccount+1
- call readnum(lineq,iccount,durq,xofforn)
- iccount = iccount-1
- if (numshft .eq. 1) then
-c
-c Vertical shift
-c 160214 Allow (-64,64)
-c iofforn = iofforn*nint(xofforn) + 16
- iofforn = iofforn*nint(xofforn) + 64
-c
-cc Turn on bit 1; set bits 2-6 to iofforn
-c Turn on bit 1 of irest; set bits 16-22 of mult to iofforn
-c
-c irest(ivx,nnl(ivx)) =
-c * ior(irest(ivx,nnl(ivx)),2+4*iofforn)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),1)
- call setbits(mult(ivx,nnl(ivx)),8,16,iofforn)
- else
-c
-c Horizontal shift
-c
- iofforn = iofforn*nint(xofforn*10)+16
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),7)
- call setbits(irest(ivx,nnl(ivx)),5,9,iofforn)
- end if
- go to 30
- else if (durq .eq. 's') then
-c
-c Slope adjustment for bracket
-c
- mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),4)
- call getchar(lineq,iccount,durq)
- iofforn = index('- +',durq)-2
- iccount = iccount+1
- call readnum(lineq,iccount,durq,xofforn)
- iccount = iccount-1
- iofforn = nint(iofforn*xofforn+16)
- call setbits(mult(ivx,nnl(ivx)),5,5,iofforn)
- else if (index('123456789',durq) .gt. 0) then
-c
-c Replacement printed number
-c
- call readnum(lineq,iccount,durq,xofforn)
- call setbits(nacc(ivx,nnl(ivx)),5,22,nint(xofforn))
- iccount = iccount-1
- go to 30
- end if
- end if
- end if
-c
-c Set note level of 1st note of xtup, provided not a rest
-c
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
- if (numnum .eq. 2) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- nolev(ivx,nnl(ivx)) = lastlev
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- nolev(ivx,nnl(ivx)) = lastlev
- end if
- end if
- do 40 npreslur = npreslur , 1 , -1
-c
-c Set note level for preslur on starting note of xtuplet
-c
- call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev)
-40 continue
- numnum = 0
- nodur(ivx,nnl(ivx)) = 0
- do 6 itup = 2 , ntup
- if (ornrpt) then
- iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),
- * iand(iornq(ivx,nnl(ivx)-1),10026991))
- if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
-c
-c This is a trill (bit 7 or 15) so must dup the parameters
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = nnl(ivx)
- xnsktr(ntrill) = xnsktr(ntrill-1)
- end if
- end if
- nnl(ivx) = nnl(ivx)+1
- if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30)
-7 call getchar(lineq,iccount,charq)
- if (charq .eq. ' ') then
- go to 7
- else if (charq .eq. '%') then
- iccount = 128
- go to 7
- else if (charq .eq. 'o') then
-c
-c Ornament in xtuplet. "o" symbol must come AFTER the affected note
-c
- if (notcrd) then
- nole = nolev(ivx,nnl(ivx)-1)
- else
- nole = iand(127,ishft(icrdat(ncrd),-12))
- end if
- call getorn(lineq,iccount,iornq(ivx,nnl(ivx)-1),
- * iornq(ivx,0),ornrpt,noffseg,
- * nnl(ivx)-1,ivx,.false.,notcrd,nole)
- go to 7
- else if (index('st(){}',charq) .gt. 0) then
- nnlivx = nnl(ivx)-1
- if (charq.eq.'(' .or. charq.eq.'{') then
-c
-c Detected preslur in xtuplet loop, non-chord note
-c
- nnlivx = nnlivx+1
- npreslur = npreslur+1
- end if
- islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0)
- if (charq.eq.'t') islur(ivx,nnlivx) =
- * ibset(islur(ivx,nnlivx),1)
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- if (fontslur) then
- call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,
- * isdat3,nsdat,notcrd,nolev(ivx,nnlivx),charq)
- else
- call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,
- * isdat3,isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq)
- end if
- go to 7
- else if (charq .eq. 'G') then
-c
-c Kluge to get grace in xtup at right location
-c
- nnl(ivx) = nnl(ivx)-1
- call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev,
- * lastlev,iv,nv)
- nnl(ivx) = nnl(ivx)+1
- go to 7
- else if (charq .eq. sq) then
- call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount)
- go to 7
- else if (charq .eq. '"') then
-c
-c pmxlyr string in xtup. Expand "..." to \pmxlyr{...}\
-c
- if (.not. inputmlyr) then
- ictemp = 0
- lineqt = sq//sq//sq//'input musixlyr '//sq
- call littex(islur,nnl(ivx)+1,ivx,topmods,lineqt,ictemp)
- inputmlyr = .true.
- end if
- call dopmxlyr(lineq,iccount)
- charq = sq
- call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount)
- go to 7
- else if (index('0123456789#-nx_',charq) .gt. 0) then
-c
-c Figure. Must come AFTER the first note of xtup
-c
- ivf = 1
- if (ivx .gt. 1) then
- if (ivxfig2 .eq. 0) then
- ivxfig2 = ivx
- else if (ivx .ne. ivxfig2) then
- print*
- print*,'Figures not allowed in >1 voice above first'
- stop
- end if
- ivf = 2
- end if
- nfig1 = nfigs(ivf)+1
- call getfig(itoff(ivf,nfig1),charq,lineq,iccount,
- * isfig(ivf,nnl(ivx)-1),itfig(ivf,nfig1),itsofar(ivx),
-c * 0,figq(ivf,nfig1),ivupfig(ivf,nfig1),nfigs(ivf))
- * 0,figq(ivf,nfig1),ivupfig(ivf,nfig1),ivvfig(ivf,nfig1),
- * nfigs(ivf))
- go to 7
- else if (charq .eq. 'X') then
- call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx)-1)),
- * shifton,wheadpt,iornq(ivx,nnl(ivx)),ivx,
- * irest(ivx,nnl(ivx)),itsofar(ivx),ntup,itup,nnodur,
- * dotq,ndoub)
- go to 7
- else if (charq .eq. 'z') then
-c
-c Chord note in xtup. Goes with *prior* note.
-c
- notcrd = .false.
- ncrd = ncrd+1
- ipl(ivx,nnl(ivx)-1) = ibset(ipl(ivx,nnl(ivx)-1),10)
- numnum = 0
-c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8))
- icrdat(ncrd) = nnl(ivx)-1
- call setbits(icrdat(ncrd),4,8,mod(ivx,16))
- if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28)
- icrdorn(ncrd) = 0
-c
-c Get note name
-c
- call getchar(lineq,iccount,charq)
-c
-c Get optional inputs
-c
-34 call getchar(lineq,iccount,durq)
-c
-c When chord note is done, will get ' ', making ndx=0, so go past this block
-c
- ndx = index('fsn+-<>12345678reicd',durq)
- if (ndx .gt. 0) then
- if (ndx .le. 3) then
- if (.not.btest(icrdat(ncrd),19)) then
- icrdat(ncrd) = ibset(icrdat(ncrd),19)
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20))
- else
- icrdat(ncrd) = ibset(icrdat(ncrd),22)
- end if
- else if (durq .eq. 'd') then
-c
-c Get dot on chord note in xtup. Assume +n+n
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),26)
- call getchar(lineq,iccount,durq)
- iccount=iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (durq .eq. '+') then
- icrdot(ncrd) = ior(icrdot(ncrd),nint(fnum*10)+64)
- else
- icrdot(ncrd) = ior(icrdot(ncrd),-nint(fnum*10)+64)
- end if
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift specified also
-c
- iccount=iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (dumq .eq. '+') then
- ifnum = nint(fnum*10)+64
- else
- ifnum = -nint(fnum*10)+64
- end if
- else
- ifnum = 64
- end if
- icrdot(ncrd) = ior(icrdot(ncrd),ishft(ifnum,7))
- iccount = iccount-1
-c iccount = iccount+4
-c
-c
-c
- else if (ndx .eq. 19) then
-c
-c Set flags for cautionary accidental
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),31)
- iornq(ivx,nnl(ivx)-1) =
- * ibset(iornq(ivx,nnl(ivx)-1),31)
- else if (ndx .le. 7) then
-c
-c +/-/</> Check whether octave or accidental shift
-c
- nactmp = 0
- call chkpm4ac(lineq,iccount,nactmp,moved)
- if (moved) then
-c
-c Transfer accidental shift values
-c
- call setbits(icrdot(ncrd),6,14,
- * igetbits(nactmp,6,4))
- call setbits(icrdot(ncrd),7,20,
- * igetbits(nactmp,7,10))
- else
- if (durq .eq. '+') then
- lastlev = lastlev+7
- else if (durq .eq. '-') then
- lastlev = lastlev-7
- end if
- end if
- else if (durq .eq. 'e') then
- icrdat(ncrd) = ibset(icrdat(ncrd),23)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- else if (durq .eq. 'r') then
- icrdat(ncrd) = ibset(icrdat(ncrd),24)
- irest(ivx,nnl(ivx)-1) =
- * ibset(irest(ivx,nnl(ivx)-1),20)
- else if (durq .eq. 'i') then
-c
-c Midi-only accidental
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),27)
- else
-c
-c must be a number, save it in ioct
-c
- numnum = 1
- ioct = ndx-7
- end if
- go to 34
- end if
- if (numnum .eq. 1) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- end if
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12))
- do 41 npreslur = npreslur , 1 , -1
-c
-c Set note level for preslur on chord note in xtup
-c
- call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
-c
-c Following lines copied from loop for non-xtup, chord note, preslur
-c Initially I assigned the slur(s) to next note, so fix.
-c
- islur(ivx,nnl(ivx)) = ibclr(islur(ivx,nnl(ivx)),0)
- islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),0)
- isdat2(nsdat-npreslur+1) =
- * ibset(isdat2(nsdat-npreslur+1),0)
- call setbits(isdat1(nsdat-npreslur+1),8,3,
- * igetbits(isdat1(nsdat-npreslur+1),8,3)-1)
-41 continue
- go to 7
- else if (charq .eq. '?') then
-c
-c Arpeggio
-c
- if (btest(ipl(ivx,nnl(ivx)-1),10)) then
-c
-c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note
-c of chord, will not set icrdat(25), but iornq(27)
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),25)
- else
- iornq(ivx,nnl(ivx)-1) = ibset(iornq(ivx,nnl(ivx)-1),27)
- end if
-c
-c Check for shift
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- else
-c
-c durq must be "-"
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
-c
-c record the shift
-c
- NumArpShift = NumArpShift+1
- IvArpShift(NumArpShift) = ivx
- IpArpShift(NumArpShift) = nnl(ivx)-1
- ArpShift(NumArpShift) = fnum
- end if
- go to 7
- else if (charq .eq. 'D') then
- call getdyn(ivx,nnl(ivx)-1,irest(ivx,nnl(ivx)-1),
- * iornq(ivx,nnl(ivx)-1),lineq,iccount)
- go to 7
-c
-c 140215 Allow clef change inside xtuplet. With normal code, came out one
-c note too late, so try making it come earlier.
-c
- else if (charq .eq. 'C') then
-c
-c Clef change on next note. Set bits 11-15. Won't allow in 2nd line of music.
-c
- if (nnl(iv)-1 .gt. 0) ncc(iv) = ncc(iv)+1
-c
-c 140218 Need to get time differently inside xtup, since itsofar doesn't get
-c updated until after xtup is done
-c
- nodurt = ifnodur(nnodur,dotq)
- tcc(iv,ncc(iv)) = itsofar(iv)+int(1.*nodurt/ntup*(itup-1))
- isl = ibset(islur(iv,nnl(iv)),11)
- call getchar(lineq,iccount,durq)
-c
-c Store clef number, or 7 if clef number = 9 (French violin clef)
-c
- isl = ior(isl,ishft(min(numclef(durq),7),12))
- ncmidcc(iv,ncc(iv)) = ncmidf(durq)
- if (durq .eq. '8') then
- ipl(iv,nnl(iv))=ibset(ipl(iv,nnl(iv)),2)
- iTransAmt(instno(iv)) = 7+iTransAmt(instno(iv))
- end if
-c
-c Set marker on note with lowest voice # starting at same time.
-c
- if (iv .eq. 1) then
- isl = ibset(isl,15)
- else
- do 70 iiv = 1 , iv
-c nnliiv = nnl(iiv)
- nnliiv = nnl(iiv)-1
- if (iiv .eq. iv) nnliiv = nnliiv+1
- itother = 0
- do 71 iip = 1 , nnliiv
- if (itother .lt. itsofar(iv)) then
- itother = itother+nodur(iiv,iip)
- go to 71
- else if (itother .eq. itsofar(iv)) then
- islur(iiv,iip) = ibset(islur(iiv,iip),15)
- go to 72
- end if
-71 continue
-70 continue
-72 continue
- end if
-c
-c Need 'or' since may have set bit 15 in the above loop
-c
-c islur(iv,nnl(iv)+1) = ior(isl,islur(iv,nnl(iv)+1))
- islur(iv,nnl(iv)) = ior(isl,islur(iv,nnl(iv)))
- go to 7
-c+++
- else if (charq .eq. ']') then
-c
-c Multiplicity up-down, must have '][ '
-c
- islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),20)
- iccount = iccount+2
- go to 7
-cc+++
- end if
-c
-c End of loop for xtup options. If here, charq must be a (non-crd) note name.
-c or rest
-c
- if (charq .eq. 'r') then
-c
-c Rest in xtup
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0)
- if (index('+-b',lineq(iccount+1:iccount+1)) .gt. 0) then
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'b') then
-c
-c Blank rest in middle of xtup
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29)
- else
-c
-c Override height of embedded xtup rest
-c
- ipm = index('- +',durq)-2
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum)
- iccount = iccount-1
- end if
- else if (ivx .le. nv) then
- nolev(ivx,nnl(ivx)) = 0
- else
- nolev(ivx,nnl(ivx)) = 2
- end if
- else
-c
-c Counter for non-rests
-c
- nnb = nnb+1
- end if
- notcrd = .true.
-8 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
- if (index('+-<>',durq) .gt. 0) then
-c
-c Accidental horizontal shift
-c
- call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved)
- if (.not.moved) then
- if (durq.eq.'+') then
- lastlev = lastlev+7
- else if (durq.eq.'-') then
- lastlev = lastlev-7
- end if
- end if
- else if (index('fsn',durq) .gt. 0) then
-c
-c if (nacc(ivx,nnl(ivx)) .eq. 0) then
-c May have set other bits earlier
- if (igetbits(nacc(ivx,nnl(ivx)),2,0) .eq. 0) then
-c
-c No accid set yet
-c
-c nacc(ivx,nnl(ivx)) = index('fsn',durq)
- nacc(ivx,nnl(ivx)) =
- * ior(nacc(ivx,nnl(ivx)),index('fsn',durq))
- else
-c
-c Symbol must be repeated, so it's a double
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2)
- end if
- else if (durq .eq. 'i') then
-c
-c Set flag for midi-only accidental
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17)
-
- else if (durq .eq. 'c') then
-c
-c Set flags for cautionary accidental
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31)
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31)
- else if (index('ul',durq) .gt. 0) then
-c
-c Force stem direction for non-beamed xtup note
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30)
- if (durq .eq. 'u') islur(ivx,nnl(ivx)) =
- * ibset(islur(ivx,nnl(ivx)),17)
- else if (durq .eq. 'e') then
-c
-c Left-shift main xtup note
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- else if (durq .eq. 'r') then
-c
-c Right-shift main xtup note
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
- else if (index('DF',durq) .gt. 0) then
-c
-c Double an xtup note to make an unequal xtup
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- if (durq .eq. 'F') nacc(ivx,nnl(ivx)) =
- * ibset(nacc(ivx,nnl(ivx)),19)
- ndoub = ndoub+1
- else if (durq .eq. 'd') then
-c
-c Dotted xtup note
-c
-c if (btest(irest(ivx,nnl(ivx))-1,2)) then
- if (btest(irest(ivx,nnl(ivx)-1),2)) then
-c
-c Move dot on 2nd note of 2-note tremolo
-c
- ndotmv(ivx) = ndotmv(ivx)+1
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),19)
- call g1etchar(lineq,iccount,durq) ! Will be + or -
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,
- * updot(ivx,ndotmv(ivx)))
- if (durq .eq. '-') updot(ivx,ndotmv(ivx)) =
- * -updot(ivx,ndotmv(ivx))
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift also
-c
- call readnum(lineq,iccount,durq,
- * rtdot(ivx,ndotmv(ivx)))
- if (durq .eq. '-') rtdot(ivx,ndotmv(ivx))
- * = -rtdot(ivx,ndotmv(ivx))
- end if
- iccount = iccount-1
- else
-c
-c Dot for 3:1 pair of xtup notes
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- end if
- else
-c
-c Must be an octave number
-c
- lastlev = ifnolev(charq,ichar(durq)-48
- * ,iTransAmt(instno(iv)))
- end if
- go to 8
- end if
- if (itup .lt. ntup) then
-c
-c Last note is handled *after* flowing out of the xtup if block, but still
-c within block for a note-rest. Set note level now (rest already done).
-c Could have problem here if rests & doubled notes are combined in xtup,
-c since might exit the loop at the wrong place. Worry about it later.
-c
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
- lastlev = lastlev-3+mod(ifnolev(charq,10,
- * iTransAmt(instno(iv)))-lastlev+3,7)
- nolev(ivx,nnl(ivx)) = lastlev
- end if
- nodur(ivx,nnl(ivx)) = 0
- do 42 npreslur = npreslur , 1 , -1
-c
-c Set note level for preslur on internal xtup note
-c
- call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
-42 continue
- end if
- if (itup .eq. ntup-ndoub) go to 12
-6 continue
-12 continue
- if (ornrpt) then
- iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),
- * iand(iornq(ivx,nnl(ivx)-1),10026991))
- if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
-c
-c This is a trill (bit 7 or 15) so must dup the parameters
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = nnl(ivx)
- xnsktr(ntrill) = xnsktr(ntrill-1)
- end if
- end if
-c
-c End of if-block for xtuplet input
-c
- else if (durq .eq. 'm') then
-c
-c Multi-bar rest: next 1 or two digits are # of bars.
-c For some purposes, pretend its one bar only
-c
- nodur(ivx,nnl(ivx)) = lenbar
- ibarmbr = nbars+1
- mbrest = 0
- xb4mbr = 0.
-20 call getchar(lineq,iccount,durq)
- if (ichar(durq).ge.48.and.ichar(durq).le.57) then
- mbrest = 10*mbrest+ichar(durq)-48
- go to 20
- end if
-c
-c durq will either be blank or 'n'
- if (durq .eq. 'n') then
-c
-c Get new height
-c
- iplmi = 1
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. '-') then
- iplmi = -1
- iccount = iccount+1
- end if
- call readnum(lineq,iccount,durq,hgt)
- mbrhgt = nint(iplmi*hgt)
- newmbrhgt = .true.
- end if
- else if (index('ul',durq) .gt. 0) then
-c
-c Set stem flipper
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30)
- if (durq .eq. 'u') islur(ivx,nnl(ivx)) =
- * ibset(islur(ivx,nnl(ivx)),17)
- go to 2
- else if (durq .eq. 'a') then
-c
-c "Alone", i.e., prohibit beam
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),18)
- go to 2
- else if (durq .eq. 'r') then
-c
-c Right offset by one notehead
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
- go to 2
- else if (durq .eq. 'e') then
-c
-c Left offset by one notehead
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- go to 2
- else if (index('LS',durq) .gt. 0) then
-c
-c Stemlength change. Get dstemlen in \internotes. Allowable values are -4 to 27.5
-c Set mult(27). Map value to 0 to 63, store in mult(10-15). Later convert to
-c interbeams = internotes*2/3.
-c
-c
- isign = 1
- if (durq .eq. 'S') isign = -1
- mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27)
- call getchar(lineq,iccount,durq)
- if (durq .eq. ':') then
-c
-c End stickyS. Grab data now from prior note, since we have to shut off stickyS.
-c
- call setbits (mult(ivx,nnl(ivx)),6,10,
- * igetbits(mult(ivx,nnl(ivx)-1),6,10))
- stickyS = .false.
- go to 2
- end if
-c
-c If durq .ne. ':' then iccount is now on the start of the number
-c
- call readnum(lineq,iccount,durq,dum)
- dum = isign*dum
- call setbits (mult(ivx,nnl(ivx)),6,10,nint((dum+4.)*2))
- if (durq .eq. ':') then
- stickyS = .true.
- else
- iccount = iccount-1
- end if
- go to 2
- else if (durq .eq. ',') then
-c
-c 2:1 pattern
-c
- idotform = 3
-c
-c Now flow to duration setting, as if durq=' '
-c
- else if (durq .eq. '.') then
-c
-c Dotted pattern. Close out note. Mult time by 3/4.
-c Set time for next note to 1/4. Start the note.
-c
- idotform = 1
- else if (durq .eq. 'o') then
-c
-c Suppress rest centering
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),25)
- go to 2
- else if (durq .eq.'L') then
-c
-c With keyboard rest option, look left
-c
-c iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),30)
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),1)
- go to 2
- else if (index('DF',durq) .gt. 0) then
-c
-c Double note for xtup. Must check here in case "D" came before "x" or on
-c last note of xtup. Need to flag it in pmxa since affects horiz. spacing.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- if (durq .eq. 'F') nacc(ivx,nnl(ivx)) =
- * ibset(nacc(ivx,nnl(ivx)),19)
- go to 2
- else if (durq .eq. 'A') then
-c
-c Accidental option
-c
- call getchar(lineq,iccount,durq)
-c
- if (durq .eq. 'o') then
-c
-c Ordered accidentals in a chord. Mark the main note.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),28)
- else
-c
-c Only other possibility is +-<> . Set tag, reduce iccount and loop to get #'s
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),29)
- iccount = iccount-1
- end if
- go to 2
- else if (durq .eq. 'T') then
- call getchar(lineq,iccount,durq)
- multtrem = index('1234',durq)
- if (multtrem .eq. 0) then
- iccount = iccount-1
- multtrem = 1
- end if
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),4)
- call setbits(ipl(ivx,nnl(ivx)),2,5,multtrem-1)
- go to 2
- else if (durq .ne. ' ') then
- print*,'Illegal character in note: ',durq,', ivx,nn:',
- * ivx,nnl(ivx)
- call stop1()
- end if
-c
-c Done with note/rest options. Set level and duration.
-c
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
- if (numnum .eq. 2) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- nolev(ivx,nnl(ivx)) = lastlev
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- nolev(ivx,nnl(ivx)) = lastlev
- end if
- do 43 npreslur = npreslur , 1 , -1
-c
-c Set level for preslur on normal note, non-chord
-c
- call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev)
-43 continue
-c
-c Only matters if last note, non-rest of xtuplet
-c
- nnb = nnb+1
- end if
-c
-c Set flag for unbeamed xtup if it just has 1 note
-c
- if (inxtup .and. nnb.eq.1) then
- islur(ivx,note1xtup) = ibset(islur(ivx,note1xtup),18)
- end if
- if (idotform .gt. 0) then
- if (idotform .eq. 1) then
- nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)*3/2
- else if (idotform .eq. 2) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3
- else if (idotform .eq. 3) then
- nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)
- else if (idotform .eq. 4) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2
- end if
- else if (btest(islur(ivx,nnl(ivx)),19)) then
-c
-c Set duration of full-bar rest as pause
-c
- nodur(ivx,nnl(ivx)) = lenbar
-c
-c Use a one-line function to set nnodur. It gives inverse of ifnodur.
-c
- nnodur = index('62514x0x37',
- * chax(48+int(log(.1+lenbar)/.69315)))-1
- else if (ibarmbr.ne.nbars+1) then
- nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)
- if (btest(islur(ivx,nnl(ivx)),3))
- * nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6
- end if
- if (shifton .and. .not.btest(irest(ivx,nnl(ivx)),16)) then
-c
-c Shift is on, and this is not first shifted note. Check for duration change
-c
- if (nodur(ivx,nnl(ivx)) .ne. nodur(ivx,nnl(ivx)-1)) then
-c
-c Must stop and restart the offset.
-c
- irest(ivx,nnl(ivx)-1) = ibset(irest(ivx,nnl(ivx)-1),17)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),16)
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = udoff(ivx,nudoff(ivx)-1)
- end if
- end if
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- if (autofbon .and. tautofb.gt.tol .and. fbon) then
-c
-c Check to see if need to terminate auto forced beam
-c
- if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then
-c
-c Terminate autofb
-c
- t2fb(ivx,nfb(ivx)) = itsofar(ivx)
- fbon = .false.
- end if
- end if
- if (mod(itsofar(ivx)-lenb0,lenbar) .eq. 0) then
-c
-c Finished a bar
-c
- nbars = nbars+1
- nib(ivx,nbars) = nnl(ivx)
- if (firstgulp.and.lenb0.ne.0.and.nbars.eq.1) then
-c
-c Just finished the pickup bar for this voice.
-c
- lenbar = lenb1
- end if
- end if
- if (idotform .eq. 1) then
- call getchar(lineq,iccount,charq)
- idotform = 2
- numnum = 1
- go to 28
- else if (idotform .eq. 3) then
- call getchar(lineq,iccount,charq)
- idotform = 4
- numnum = 1
- go to 28
- end if
-c
-c End of sub block for note-rest
-c
- else if (charq .eq. 'z') then
-c
-c Chord note. Must have note name, may have octave#,+,-,s,f,n,d
-c Actually the 'd' is not used, since time value comes from
-c basic note. Unless dot is to be shifted!
-c Doesn't increase # of notes, so must handle separately
-c ncrd: index of crd
-c Set bit 10 of ipl on main note as flag
-c Bits in icrdat:
-c 0-7 ip within voice
-c 8-11 ivx
-c 12-18 note level
-c 19 accidental?
-c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp)
-c 23 shift left
-c 24 shift right
-c 25 arpeggio start or stop
-c 26 flag for moved dot (here, not icrdot, since this is always reset!)
-c 27 Midi-only accidental
-c 29 Tag for accidental shift...means add to autoshifts.
-c 31 Cautionary accidental
-c
-c Bits in icrdot:
-c 0-6 10*abs(vertical dot shift in \internote) + 64
-c 7-13 10*abs(horizontal dot shift in \internote) + 64
-c 14-19 vert accidental shift-32
-c 20-26 20*(horiz accidental shift+3.2)
-c 27-29 top-down level rank of chord note w/accid. Set in crdaccs.
-c
-c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds.
-c
- ncrd = ncrd+1
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),10)
- numnum = 0
-c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8))
- icrdat(ncrd) = nnl(ivx)
- call setbits(icrdat(ncrd),4,8,mod(ivx,16))
- if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28)
- icrdot(ncrd) = 0
- icrdorn(ncrd) = 0
-c
-c Get note name
-c
- call getchar(lineq,iccount,charq)
-c
-c Get optional inputs
-c
-25 call getchar(lineq,iccount,durq)
-c ndx = index('fsn+-<>12345678rediA',durq)
- ndx = index('fsn+-<>12345678rediAc',durq)
- if (ndx .eq. 20) then
-c
-c Expect +|-|<|> , set tag, loop
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),29)
- go to 25
- else if (ndx .gt. 0) then
- if (ndx .le. 3) then
- if (.not.btest(icrdat(ncrd),19)) then
- icrdat(ncrd) = ibset(icrdat(ncrd),19)
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20))
- else
- icrdat(ncrd) = ibset(icrdat(ncrd),22)
- end if
- else if (ndx .eq. 21) then
-c
-c Set flags for cautionary accidental
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),31)
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31)
- else if (ndx .le. 7) then
-c
-c +/-/</> Check whether octave or accidental shift
-c
- nactmp = 0
- call chkpm4ac(lineq,iccount,nactmp,moved)
- if (moved) then
-c
-c Transfer accidental shift values
-c
- call setbits(icrdot(ncrd),6,14,igetbits(nactmp,6,4))
- call setbits(icrdot(ncrd),7,20,igetbits(nactmp,7,10))
- else
- if (durq .eq. '+') then
- lastlev = lastlev+7
- else if (durq .eq. '-') then
- lastlev = lastlev-7
- end if
- end if
- else if (durq .eq. 'e') then
- icrdat(ncrd) = ibset(icrdat(ncrd),23)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- else if (durq .eq. 'r') then
- icrdat(ncrd) = ibset(icrdat(ncrd),24)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
- else if (durq .eq. 'i') then
-c
-c Midi-only accidental on chord note
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),27)
- else if (durq .eq. 'd') then
-c
-c Must keep 'd' optional (backward compatibility), unless it is moved!
-c
- if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
-c
-c move a dot, unless next char is not part of a number
-c
- if (index('0123456789.',lineq(iccount+2:iccount+2))
- * .eq. 0) go to 25
- icrdat(ncrd) = ibset(icrdat(ncrd),26)
- call getchar(lineq,iccount,durq)
- iccount=iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (durq .eq. '+') then
- icrdot(ncrd) = ior(icrdot(ncrd),nint(fnum*10)+64)
- else
- icrdot(ncrd) = ior(icrdot(ncrd),-nint(fnum*10)+64)
- end if
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift specified also
-c
- iccount=iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (dumq .eq. '+') then
- ifnum = nint(fnum*10)+64
- else
- ifnum = -nint(fnum*10)+64
- end if
- else
- ifnum = 64
- end if
- icrdot(ncrd) = ior(icrdot(ncrd),ishft(ifnum,7))
- iccount = iccount-1
- end if
- else
-c
-c must be a single digit, save it in ioct
-c
- numnum = 1
- ioct = ndx-7
- end if
- go to 25
- end if
- if (numnum .eq. 1) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- end if
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12))
- do 44 npreslur = npreslur , 1 , -1
- call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
-c
-c Set level for chord note.
-c Initially I assigned the slur(s) to next note, so fix.
-c
- islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),0)
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),0)
- isdat2(nsdat-npreslur+1) = ibset(isdat2(nsdat-npreslur+1),0)
- call setbits(isdat1(nsdat-npreslur+1),8,3,
- * igetbits(isdat1(nsdat-npreslur+1),8,3)-1)
-44 continue
- if (notcrd) then
-c
-c This is the first chord note in this chord.
-c
- minlev = min(nolev(ivx,nnl(ivx)),lastlev)
- maxlev = max(nolev(ivx,nnl(ivx)),lastlev)
- else
- minlev = min(minlev,lastlev)
- maxlev = max(maxlev,lastlev)
- end if
- notcrd = .false.
- else if (charq .eq. 'G') then
- call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev,
- * lastlev,iv,nv)
-c
-c Grace, comes *before* main note:
-c UNLESS there's an 'A' or 'W' after the 'G'
-c ngrace = # of grace note groups so far in block
-c ivg(ngrace), ipg(ngrace)
-c nng(ngrace) = # of notes in this group: default = 1
-c ngstrt(ngrace) = starting position in nolevg of levels for this grace
-c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)'
-c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l'
-c slurg(ngrace) = logical for slur; default F, input 's'
-c slashg(ngrace) = T if slash; default is F, input 'x'
-c These data MUST precede note name of first note
-c nolevg, naccg: lists of levels and accid's, indexed as described above.
-c
- else if (charq .eq. sq) then
-c
-c Literal TeX string
-c
- call littex(islur,nnl(ivx)+1,ivx,topmods,lineq,iccount)
- else if (charq .eq. '"') then
-c
-c pmxlyr string. Expand "..." to \pmxlyr{...}\
-c
- if (.not. inputmlyr) then
- ictemp = 0
- lineqt = sq//sq//sq//'input musixlyr '//sq
- call littex(islur,nnl(ivx)+1,ivx,topmods,lineqt,ictemp)
- inputmlyr = .true.
- end if
- call dopmxlyr(lineq,iccount)
- charq = sq
- call littex(islur,nnl(ivx)+1,ivx,topmods,lineq,iccount)
- else if (charq .eq. 'o') then
-c
-c Ornament on non-xtup note. Symbol must come AFTER the affected note
-c
- if (notcrd) then
- nole = nolev(ivx,nnl(ivx))
- else
- nole = iand(127,ishft(icrdat(ncrd),-12))
- end if
- call getorn(lineq,iccount,iornq(ivx,nnl(ivx)),
- * iornq(ivx,0),ornrpt,noffseg,nnl(ivx),ivx,
- * .true.,notcrd,nole)
- else if (index('st(){}',charq) .gt. 0) then
- nnlivx = nnl(ivx)
- if (charq.eq.'(' .or. charq.eq.'{') then
-c
-c Detect preslur on normal non-chord note
-c
- nnlivx = nnlivx+1
- npreslur = npreslur+1
- end if
- islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0)
- if (charq.eq.'t')
- * islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),1)
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- if (fontslur) then
- call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3,
- * nsdat,notcrd,nolev(ivx,nnlivx),charq)
- else
- call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3,
- * isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq)
- end if
- else if (charq .eq. '?') then
-c
-c Arpeggio
-c
- if (btest(ipl(ivx,nnl(ivx)),10)) then
-c
-c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note
-c of chord, will not set icrdat(25), but iornq(27)
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),25)
- else
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),27)
- end if
-c
-c Check for shift
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- else
-c
-c durq must be "-"
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
-c
-c record the shift
-c
- NumArpShift = NumArpShift+1
- IvArpShift(NumArpShift) = ivx
- IpArpShift(NumArpShift) = nnl(ivx)
- ArpShift(NumArpShift) = fnum
- end if
- else if (index('0123456789#-nx_',charq) .gt. 0) then
-c
-c We have a figure. Must come AFTER the note it goes under
-c
-
- ivf = 1
- if (ivx .gt. 1) then
- if (ivxfig2 .eq. 0) then
- ivxfig2 = ivx
- else if (ivx .ne. ivxfig2) then
- print*
- print*,'Figures not allowed in >1 voice above first'
- stop
- end if
- ivf = 2
- end if
- nfig1 = nfigs(ivf)+1
- call getfig(itoff(ivf,nfig1),charq,lineq,iccount,
- * isfig(ivf,nnl(ivx)),itfig(ivf,nfig1),itsofar(ivx),
- * nodur(ivx,nnl(ivx)),figq(ivf,nfig1),
-c * ivupfig(ivf,nfig1),nfigs(ivf))
- * ivupfig(ivf,nfig1),ivvfig(ivf,nfig1),nfigs(ivf))
- else if (charq .eq. '[') then
-c
-c Start forced beam. Record barno & time since start of inp. blk. Set signal
-c
- nfb(ivx) = nfb(ivx)+1
- fbon = .true.
- ulfbq(ivx,nfb(ivx)) = 'x'
- t1fb(ivx,nfb(ivx)) = itsofar(ivx)
- nadj = 0
- if (autofbon) then
- autofbon = .false.
- end if
-17 call getchar(lineq,iccount,charq)
- if (index('ulf',charq) .gt. 0) then
- ulfbq(ivx,nfb(ivx)) = charq
- go to 17
- else if (charq .eq. 'j') then
-c
-c Continuing a jumped beam here
-c
- irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),24)
-c
-c Set flag to watch for END of this forced beam, so can set flag rest(30) on
-c NEXT note as signal to start a new notes group there.
-c
- isbj2 = .true.
- go to 17
- else if (charq .eq. 'h') then
- islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),2)
- go to 17
- else if (charq .eq. 'm') then
-c
-c Force multiplicity. Next input is digit
-c
- call getchar(lineq,iccount,charq)
- islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),21)
- call setbits(islur(ivx,nnl(ivx)+1),3,22,ichar(charq)-48)
- go to 17
- else if (charq .eq. ':') then
-c
-c Start auto forced beam pattern
-c
- autofbon = .true.
-c
-c When forced later beam ends, check whether tautofv <=0; if so set it.
-c
- tautofb = -itsofar(ivx)
- t1autofb = itsofar(ivx)
- go to 17
- else if (charq .ne. ' ') then
-c
-c Must be '+/-' for height or slope shift
-c
- nadj = nadj+1
-c
-c nadj = 1,2, or 3 for normal start level, slope, or beam-thk start level.
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- iadj = nint(fnum)
- if (charq .eq. '-') iadj = -iadj
- if (nadj .eq. 1) then
-c
-c This is a level shift. Note if 0 was entered, iadj = 30
-c
- call setbits(ipl(ivx,nnl(ivx)+1),6,11,iadj+30)
- else if (nadj .eq. 2) then
-c
-c Must be a slope shift
-c
- call setbits(ipl(ivx,nnl(ivx)+1),6,17,iadj+30)
- else
-c
-c Beam-thk fine tune
-c
- call setbits(islur(ivx,nnl(ivx)+1),2,27,iadj)
- end if
- go to 17
- end if
- else if (charq .eq. ']') then
- if (autofbon .and. tautofb.lt.tol) then
- tautofb=itsofar(ivx)+tautofb
- end if
- call getchar(lineq,iccount,charq)
- if (index('j ',charq) .gt. 0) then
-c
-c Since ']' comes AFTER note, itsofar has been updated. Set ending signal.
-c
- t2fb(ivx,nfb(ivx)) = itsofar(ivx)
- fbon = .false.
- if (charq .eq. 'j') then
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),23)
- end if
- if (isbj2) then
-c
-c This is the end of a fb segment of a jump beam. Set flag on NEXT note to
-c force start of new notes group, provided this is not last note in bar.
-c
- if (mod(itsofar(ivx),lenbar) .ne. 0)
- * irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),30)
- isbj2 = .false.
- end if
- else if (charq .eq. '[') then
-c
-c Multiplicity down-up signal
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),20)
- else if (charq .eq. '-') then
-c
-c Set signals for gap in single-slope beam [...]-[...]
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),20)
- nacc(ivx,nnl(ivx)+1) = ibset(nacc(ivx,nnl(ivx)+1),21)
-c
-c Next two characters must be "[ ". Skip over them.
-c
- iccount = iccount+2
- end if
- else if (charq .eq. 'D') then
- call getdyn(ivx,nnl(ivx),irest(ivx,nnl(ivx)),
- * iornq(ivx,nnl(ivx)),lineq,iccount)
- else if (charq .eq. 'h') then
-c
-c Heading or height. For heading, only OK if at start of block
-c Check whether at beginning of a block
-c
- if (iv.ne.1 .or. nnl(1).ne.0) then
- print*,'You entered "h" not at beginning of block'
- call stop1()
- end if
- call getchar(lineq,iccount,durq)
- ihdvrt = 0
- if (index('+-',durq) .gt. 0) then
-c
-c Vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- ihdvrt = fnum+.1
- if (durq .eq. '-') ihdvrt = -ihdvrt
- durq = charq
- end if
- if (durq .ne. ' ') then
-c
-c Height symbol. Read past (until next blank)
-c
-3 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') go to 3
- else
-c
-c Set flag for header & read it in
-c
- ihdht = 16
- call getbuf(headrq)
- iccount = 128
- end if
- else if (charq .eq. 'L') then
-c
-c Linebreak, already handled some in pmxa, but need to get data for
-c shortened line or coda lengths
-c
- iccount = iccount+1
- if (lineq(iccount:iccount) .eq. 'C') then
-c
-c Coda, get length
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,codafrac)
- ishort = 3
- if (durq .eq. 'n') nocodabn = .true.
- return
- end if
-c
-c Get line number
-c
- call readnum(lineq,iccount,durq,fmovbrk)
-48 continue ! Allow transfer up from below if S follows M
- if (durq .eq. 'S') then
-c
-c Shortened line, get shortening fraction
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,shortfrac)
- ishort = 1
- codafrac = 0.
- end if
-c
-c Begin check for movement break
-c
- if (durq .eq. 'P') then
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- end if
- if (durq .eq. 'M') then
- movbrk = nint(fmovbrk)
- movgap = 0
- parmov = -1.
- call getchar(lineq,iccount,durq)
-31 if (durq .eq. '+') then
-c
-c Get vertical space (\internotes)
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- movgap = nint(fnum)
- go to 31
- else if (durq .eq. 'i') then
- iccount = iccount+1
- call readnum(lineq,iccount,durq,parmov)
- go to 31
- else if (durq .eq. 'c') then
- nobar1 = .true.
- call getchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'r') then
-c
-c "rename" can be set on or off.
-c
- call getchar(lineq,iccount,durq)
- rename = durq.eq.'+'
- call getchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'n') then
-c
-c Change # of voices. Input ninow, iiorig(1...ninow). Will use names,
-c staves per inst. and clefs corr. to iiorig in original list of instruments.
-c
- nvold = nv
- nv = 0
- rename = .true.
- call getchar(lineq,iccount,durq)
- if (durq .eq. ':') then
- iccount = iccount+2
- read(lineq(iccount-1:iccount),'(i2)')ninow
- else
- ninow = ichar(durq)-48
- end if
- iiv = 0
- do 63 iinow = 1 , ninow
- call getchar(lineq,iccount,durq)
- if (durq .eq. ':') then
- iccount = iccount+2
- read(lineq(iccount-1:iccount),'(i2)')iiorig(iinow)
- else
- iiorig(iinow) = ichar(durq)-48
- end if
- nspern(iinow) = nsperi(iiorig(iinow))
- nv = nv+nspern(iinow)
- sepsymq(iiv+nspern(iinow)) = '&'
- if (nspern(iinow) .gt. 1) then
- do 64 iis = 1 , nspern(iinow)-1
- sepsymq(iiv+iis) = '|'
-64 continue
- end if
- iiv = iiv+nspern(iinow)
-63 continue
-c
-c 120818 Per Rainer's suggestion, defer changing \nbinstruments until issuing \newmovement
-c
-c if (islast) then
-c if (ninow .lt. 10) then
-c write(11,'(a)')sq//'newnoi{'//chax(ninow+48)//'}%'
-c else
-c write(11,'(a8,i2,a2)')sq//'newnoi{',ninow,'}%'
-c end if
-c end if
- if (nv.eq.1 .and. nvold.gt.1) then
- if (islast) write(11,'(a)')sq//'nostartrule'
- else if (nv.gt.1 .and. nvold.eq.1) then
- if (islast) write(11,'(a)')sq//'startrule'
- end if
- iiv = 0
- do 60 iinow = 1 , ninow
- do 61 iis = 1 , nspern(iinow)
- iiv = iiv+1
-c
-c May not really need to re-enter clefs, but it's easier to program since
-c clef names are not saved but are needed in newvoice to set ncmidcc.
-c
- call getchar(lineq,iccount,clefq(iiv))
- call newvoice(iiv,clefq(iiv),.true.)
- if (nspern(iinow) .eq. 1) then
- hdlndq = chax(48+numclef(clefq(iiv)))
- lclf = 1
- else if (iis .eq. 1) then
- hdlndq = '{'//chax(48+numclef(clefq(iiv)))
- lclf = 2
- else if (iis .lt. nspern(iinow)) then
- hdlndq = hdlndq(1:lclf)//chax(48+numclef(clefq(iiv)))
- lclf = lclf+1
- else
- hdlndq =
- * hdlndq(1:lclf)//chax(48+numclef(clefq(iiv)))//'}'
- lclf = lclf+2
- end if
-61 continue
-c
-c setstaffs & setclef go by instrument, not voice
-c
- if (islast) then
- if (iinow .lt. 10) then
- write(11,'(a)')sq//'setstaffs'
- * //chax(48+iinow)//chax(48+nspern(iinow))//'%'
- write(11,'(a)')sq//'setclef'//chax(48+iinow)
- * //hdlndq(1:lclf)//'%'
- if (fullsize(iiorig(iinow)).gt.0.9) then
- write(11,'(a)')sq//'setsize'//chax(48+iinow)
- * //sq//'normalvalue%'
-c
-c 140526 Account for staff size specs when noinst changes. May be confusion
-c here if more than one staff per instrument
-c
- else if (fullsize(iiorig(iinow)).gt..7) then
- write(11,'(a)')sq//'setsize'//chax(48+iinow)
- * //sq//'smallvalue%'
- else
- write(11,'(a)')sq//'setsize'//chax(48+iinow)
- * //sq//'tinyvalue%'
- end if
- else
- write(11,'(a11,i2,a)')sq//'setstaffs{',iinow,
- * '}'//chax(48+nspern(iinow))//'%'
- write(11,'(a9,i2,a)')sq//'setclef{',iinow,
- * '}'//hdlndq(1:lclf)//'%'
- end if
- end if
-60 continue
-c
-c Loop back up, this may not be last option in M. Note flow out if durq=' '
-c
- call getchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'S') then
- go to 48
- end if
-c
-c Write instrument names
-c
- if (.not.rename) then
- do 62 iinst = 1 , ninow
- if (islast) then
- if (iinst .lt. 10) then
- write(11,'(a8,i1,a3)')sq//'setname',iinst,'{}%'
- else
- write(11,'(a9,i2,a4)')sq//'setname{',iinst,'}{}%'
- end if
- end if
-62 continue
- else
- do 65 iinst = 1 , ninow
- if (islast) then
- if (iinst .lt. 10) then
- write(11,'(a8,i1,a)')sq//'setname',iinst,'{'//
- * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%'
- else
- write(11,'(a9,i2,a)')sq//'setname{',iinst,'}{'//
- * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%'
- end if
- end if
-65 continue
- if (ishort.ne.4.and.ishort.ne.2) rename = .false.
-c
-c Reset later and rewrite setname{} in shortening case mcm, since if
-c written here it will be inside {{...}} and will be ignored
-c
- end if
- end if
- else if (charq .eq.'|' ) then
-c
-c End of bar symbol. Check about end of bar hardspace.
-c
- if (btest(iornq(ivx,nnl(ivx)+1),26)) then
-c
-c There was a hardspace followed by a bar line. Remove it from the hardspace
-c list, store with shifts instead, set special bit. Need to repeat this code
-c at '/'.
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18)
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = udsp(nudsp)
- nudsp = nudsp-1
- iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26)
- end if
- else if (index('wS',charq) .gt. 0) then
-c
-c Width symbol or new nsyst. Read past (until blank)
-c
-4 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') go to 4
- else if (charq .eq. 'l') then
-c
-c Lower string. Only OK if at start of block
-c Check whether at beginning of a block
-c
- if (iv.ne.1 .or. nnl(1).ne.0) then
- print*,'You entered "l" not at beginning of block'
- call stop1()
- end if
-c
-c Set flag for lower string & read it in
-c
- lower = .true.
- call getbuf(lowerq)
- iccount = 128
- else if (charq .eq. 'm') then
-c
-c Meter change. Only allow at beginning of block.
-c mtrnuml, mtrdenl (logical) and p (printable) will be input.
-c mtrnuml=0 initially. (In common)
-c
-c Check whether at beginning of a block
-c
- if (iv.ne.1 .or. nnl(1).ne.0) then
- print*,'You entered "m" not at beginning of block'
- call stop1()
- end if
- call readmeter(lineq,iccount,mtrnuml,mtrdenl)
- call readmeter(lineq,iccount,mtrnmp,mtrdnp)
- lenbeat = ifnodur(mtrdenl,'x')
- if (mtrdenl .eq. 2) lenbeat = 16
- lenbar = mtrnuml*lenbeat
- if (mtrdenl .eq. 2) lenbar = lenbar*2
- lenb1 = lenbar
- lenb0 = 0
- if (ismidi) call midievent('m',mtrnuml,mtrdenl)
- else if (charq .eq. 'C') then
-c
-c Clef change on next note. Set bits 11-15. Won't allow in 2nd line of music.
-c
- if (nnl(iv) .gt. 0) ncc(iv) = ncc(iv)+1
- tcc(iv,ncc(iv)) = itsofar(iv)
- isl = ibset(islur(iv,nnl(iv)+1),11)
- call getchar(lineq,iccount,durq)
-c
-c Store clef number, or 7 if clef number = 9 (French violin clef)
-c
- isl = ior(isl,ishft(min(numclef(durq),7),12))
- ncmidcc(iv,ncc(iv)) = ncmidf(durq)
- if (durq .eq. '8') then
- ipl(iv,nnl(iv)+1)=ibset(ipl(iv,nnl(iv)+1),2)
- iTransAmt(instno(iv)) = 7+iTransAmt(instno(iv))
- lastlev = lastlev+7
- if (nnl(iv).eq.0) then
- ndlev(iv,1) = ndlev(iv,1)+7
- ndlev(iv,2) = ndlev(iv,2)+7
- end if
- else
-c
-c This won't work if you really had an octave transposition with some
-c other clef. Need a check on whether prior clef was an octave clef.
-c
- if (iTransAmt(instno(iv)).eq.7) then
- iTransAmt(instno(iv))=iTransAmt(instno(iv))-7
- lastlev = lastlev-7
- if (nnl(iv).eq.0) then
- ndlev(iv,1) = ndlev(iv,1)-7
- ndlev(iv,2) = ndlev(iv,2)-7
- end if
- end if
- end if
-c
-c Set marker on note with lowest voice # starting at same time.
-c
- if (iv .eq. 1) then
- isl = ibset(isl,15)
- else
- do 13 iiv = 1 , iv
- nnliiv = nnl(iiv)
- if (iiv .eq. iv) nnliiv = nnliiv+1
- itother = 0
- do 14 iip = 1 , nnliiv
- if (itother .lt. itsofar(iv)) then
- itother = itother+nodur(iiv,iip)
- go to 14
- else if (itother .eq. itsofar(iv)) then
- islur(iiv,iip) = ibset(islur(iiv,iip),15)
- go to 15
- end if
-14 continue
-13 continue
-15 continue
- end if
-c
-c Need 'or' since may have set bit 15 in the above loop
-c
- islur(iv,nnl(iv)+1) = ior(isl,islur(iv,nnl(iv)+1))
- else if (charq .eq. 'R') then
-c
-c Repeats. set bits 5, 6, and/or 8 of islur(1,ip+1)
-c
-10 call getchar(lineq,iccount,durq)
-c
-c Save designator in case it's a terminal Rr or Rd
-c
- if (durq .eq. 'l') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),5)
- go to 10
- else if (index('rdDbz',durq) .gt. 0) then
- if (durq .eq. 'r') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),6)
- else if (durq .eq. 'd') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),8)
- else if (durq .eq. 'D') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),26)
- else if (durq .eq. 'b') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),25)
- else if (durq .eq. 'z') then
-c iornq(1,nnl(1)+1) = ibset(iornq(1,nnl(1)+1),29)
- ipl(1,nnl(1)+1) = ibset(ipl(1,nnl(1)+1),0)
- end if
- rptprev = .true.
- rptfq1 = durq
- go to 10
- end if
- else if (charq .eq. 'V') then
-c
-c Ending
-c
- nnnl = nnl(1)+1
- lvoltxt = 0
-11 call getchar(lineq,iccount,durq)
- if (durq.eq.'b' .or. durq .eq.'x') then
-c
-c End Volta, set bit9, and bit10 on if 'b' (end w/ box)
-c
- islur(1,nnnl) = ibset(islur(1,nnnl),9)
- if (durq .eq. 'b') islur(1,nnnl) = ibset(islur(1,nnnl),10)
- go to 11
- else if (durq .ne. ' ') then
-c
-c Start volta; Get text
-c
- if (lvoltxt .eq. 0) then
-c
-c First character for text
-c
- lvoltxt = 1
- islur(1,nnnl) = ibset(islur(1,nnnl),7)
- nvolt = nvolt+1
- voltxtq(nvolt) = durq
- else
- voltxtq(nvolt) = voltxtq(nvolt)(1:lvoltxt)//durq
- lvoltxt = lvoltxt+1
- end if
- go to 11
- end if
- else if (charq .eq. 'B') then
- bcspec = .not.bcspec
- else if (charq .eq. 'P') then
-c
-c Page numbers. Print stuff right now.
-c
- npg1 = 0
-c
-c Will use ltopnam to signal whether there's a centered heading
-c
- ltopnam = 0
- ipg1r = 0
-16 call getchar(lineq,iccount,durq)
- if (ichar(durq).ge.48 .and. ichar(durq).le.57) then
- npg1 = npg1*10+ichar(durq)-48
- go to 16
- else if (durq .eq. 'l') then
- if (npg1.eq.0 .or. mod(npg1,2).eq.1) ipg1r = 1
- go to 16
- else if (durq .eq. 'r') then
- if (npg1.gt.0 .and. mod(npg1,2).eq.0) ipg1r = 1
- go to 16
- else if (durq .eq. 'c') then
-c
-c Top-centered name. Assume this is last option. Read the name.
-c May surround name in double quotes (to allow blanks).
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- ltopnam = lenstr(cheadq,60)
- else
- namstrt = iccount
- if (durq .eq. '"') then
-c
-c Using quote delimiters.
-c
- quoted = .true.
- namstrt = namstrt+1
- else
- quoted = .false.
- end if
- do 35 iccount = namstrt+1, 128
-c if ((quoted .and. lineq(iccount:iccount) .eq. '"') .or.
- if ((quoted .and. lineq(iccount:iccount).eq.'"' .and.
- * lineq(iccount-1:iccount-1).ne.'\') .or.
- * (.not.quoted .and. lineq(iccount:iccount) .eq. ' '))
- * go to 36
-c
-c On exit, iccount is OK, and name is in (namstrt:iccount-1)
-c
-35 continue
- print*,'Awww, cmon, should not be here.'
- call stop1()
-36 continue
- ltopnam = iccount-namstrt
- cheadq = lineq(namstrt:iccount-1)
- end if
- end if
-c
-c Done getting data, now assemble the command
-c
- if (npg1.eq.0) npg1=1
-c
-c 2/23/03 Don't use \atnextline if on first page and only one system
-c
-c if (ipage.gt.1 .or. nsystp(1).gt.1) then
- hdlndq = sq//'def'//sq//'atnextline{'//sq//'toppageno{'
- lhead = 27
-c else
-c hdlndq = sq//'toppageno{'
-c lhead = 11
-c end if
- if (npg1 .lt. 10) then
-c
-c Note we are overwriting the last "{"
-c
- write(hdlndq(lhead:lhead),'(i1)')npg1
- else if (npg1 .lt. 100) then
- lhead = lhead+3
- write(hdlndq(lhead-2:lhead),'(i2,a1)')npg1,'}'
- else
- lhead = lhead+4
- write(hdlndq(lhead-3:lhead),'(i3,a1)')npg1,'}'
- end if
- hdlndq = hdlndq(1:lhead)//chax(ipg1r+48)//'{'
- lhead = lhead+2
-c if (ipage.gt.1 .or. nsystp(1).gt.1) then
- if (ltopnam .eq. 0) then
- if (islast) write(11,'(a)')hdlndq(1:lhead)//'}}%'
- else
- if (islast)
- * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}}%'
- end if
-c else
-c if (ltopnam .eq. 0) then
-c if (islast) write(11,'(a)')hdlndq(1:lhead)//'}%'
-c else
-c if (islast)
-c * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}%'
-c end if
-c end if
- else if (charq .eq. 'W') then
-c
-c Just eat the number that must follow, it was used in pmxa
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- else if (charq .eq. 'T') then
- headlog = .true.
- inhead = 0
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'i') then
- call getbuf(instrq)
-c
-c A kluge for parts from separate score file for later movements.
-c
- if (instrq(1:1) .eq. ' ') headlog = .false.
- cheadq = instrq(1:60)
- else if (durq .eq. 't') then
- call getchar(lineq,iccount,durq)
-c
-c Optionally can include extra vertical \internotes above inbothd
-c
- if (index('-+0123456789',durq) .gt. 0) then
- ipm = 1
- if (index('+-',durq) .gt. 0) then
-c
-c Don't trust readnum to round this negative integer properly
-c
- iccount = iccount+1
- if (durq .eq. '-') ipm = -1
- end if
- call readnum(lineq,iccount,durq,fnum)
- inhead = ipm*nint(fnum)
- end if
- call getbuf(titleq)
- else
- call getbuf(compoq)
- end if
- inhead = inhead+inbothd
- iccount = 128
- else if (charq .eq. 'A') then
-c
-c Accidental handling etc.
-c
-27 call getchar(lineq,iccount,durq)
- if (durq .eq. 'r') then
- if (islast) then
- relacc = .true.
- write(11,'(a)')sq//'relativeaccid%'
- end if
- else if (durq .eq. 's') then
- bacfac = 1.e6
- else if (durq .eq. 'b') then
- if (islast) write(11,'(a)')sq//'bigaccid%'
- accfac = bacfac
- else if (durq .eq. 'a') then
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- else if (durq .eq. 'i') then
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,tintstf)
- if (.not.firstgulp) fintstf = tintstf
-c
-c Local corrections for first page were handled by pmxa
-c
- iccount = iccount-1
- else if (durq .eq. 'I') then
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,gintstf)
- iccount = iccount-1
- else if (durq .eq. 'd') then
- lowdot = .true.
- else if (durq .eq. 'o') then
- continue
- else if (durq .eq. 'S') then
- do 50 iiv = 1 , noinst
- call getchar(lineq,iccount,durq)
- if (index('-s',durq) .gt. 0) then
- fullsize(iiv) = 0.8
- else if (durq .eq. 't') then
- fullsize(iiv) = 0.64
- else
-c fullsize(ivx) = 1.0
- fullsize(iiv) = 1.0
- end if
-50 continue
- else if (durq .eq. 'e') then
-c
-c Line-spacing equalization
-c
- equalize = .true.
-c
-c The following redefinition of \parskip was put into pmx.tex in version 2.25 or so.
-c But it causes problems with some older scores and when excerpts are combined
-c with LaTeX. So as of 2.352 we write it here.
-c
- write(11,'(a)')sq//'global'//sq//'parskip 0pt plus 12'//sq
- * //'Interligne minus 99'//sq//'Interligne%'
- tempq = sepsymq(1)
- lentemp = 1
- do 51 iiv = 2 , nv-1
- tempq = tempq(1:lentemp)//sepsymq(iiv)
- lentemp = lentemp+1
-51 continue
- write(11,'(a)')sq//'def'//sq//'upstrut{'//sq//'znotes'
- * //tempq(1:lentemp)//sq//'zcharnote{'//sq//'upamt}{~}'
- * //sq//'en}%'
- else if (durq .eq. 'v') then
-c
-c Toggle usevshrink
-c
- usevshrink = .not.usevshrink
- else if (durq .eq.'p') then
-c
-c Postscript slurs. fontslur is already false (set in g1etnote)
-c
- if (.not.WrotePsslurDefaults) then
-c
-c Set postscrirpt slur adjustment defaults
-c
- write(11,'(a)')sq//'Nosluradjust'//sq//'Notieadjust'
- * //sq//'nohalfties'
- WrotePsslurDefaults = .true.
- end if
-52 continue
- call g1etchar(lineq,iccount,durq) ! might be "+", "-", "h" or "l"
- if (index('+-',durq) .gt. 0) then
-c
-c Characters to change defaults for ps slurs
-c
- call g1etchar(lineq,iccount,charq) ! charq will be "s,t,h,c"
- if (durq .eq. '+') then
- if (charq .eq. 's') then
- write(11,'(a)')sq//'Sluradjust'
- else if (charq .eq. 't') then
- write(11,'(a)')sq//'Tieadjust'
- else if (charq .eq. 'h') then
- write(11,'(a)')sq//'halfties'
- else
- SlurCurve = SlurCurve + 1
- if (SlurCurve .gt. 3.1) then
- call printl('WARNING!')
- call printl
- * ('Default slur curvature advanced past HH, resetting')
- SlurCurve = 3
- end if
- end if
- else
- if (charq .eq. 's') then
- write(11,'(a)')sq//'Nosluradjust'
- else if (charq .eq. 't') then
- write(11,'(a)')sq//'Notieadjust'
- else if (charq .eq. 'h') then
- write(11,'(a)')sq//'nohalfties'
- else
- SlurCurve = SlurCurve - 1
- if (SlurCurve .lt. -1.1) then
- call printl('WARNING!')
- call printl(
- * 'Default slur curvature decremented below f, resetting')
- SlurCurve = -1
- end if
- end if
- end if
- go to 52 ! Check for another set of default changes
- else if (durq .eq. 'l') then
-c
-c Set optional linebreak ties
-c
- OptLineBreakTies = .true.
- go to 52
- else if (durq .eq. 'h') then
-c
-c Set flag to write header special on every page
-c
- HeaderSpecial = .true.
- go to 52
- else
- iccount = iccount-1
- end if
- else if (durq .eq. 'K') then
-c
-c Toggle keyboard rest placement flag
-c
- kbdrests = .not.kbdrests
- else if (durq .eq. 'c') then
- call g1etchar(lineq,iccount,durq)
-c
-c Just eat the input; it was used in pmxa
-c
- go to 27
- else if (durq .eq. 'V') then
- bottopgap = .true.
- topamt = 0.
- call getchar(lineq,iccount,durq)
- pmfac = index('- +',durq)-2
- call g1etchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,botamt)
- botamt = botamt*pmfac
- pmfac = index('- +',durq)-2
- call g1etchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,topamt)
- topamt = topamt*pmfac
- iccount = iccount-1
- go to 27
- end if
- if (index('NR',durq) .gt. 0) then
-c
-c Override default part names for scor2prt, or normal include file.
-c Just bypass rest of input line
-c
- iccount = 128
- else if (durq .ne. ' ') then
- go to 27
- end if
- else if (charq .eq. 'K') then
-77 continue
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'n') then
- ignorenats = .true.
- go to 77
- end if
- if (durq .ne. 'i') then
-c
-c Normal, full-score key change and/or transposition
-c
- num1 = 44-ichar(durq)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- num1 = num1*nint(fnum)
-c
-c On exit, durq='+','-'. But only need isig if after start, else done in pmxa
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- if (ismidi) then
- midisig = nint(fnum)
- if (durq.eq.'-') midisig = -midisig
-c 130317
- midisig = midisig+idsig
- call midievent('k',midisig,0)
-
- end if
-c70 continue
- if (num1 .eq. 0) then
-c
-c Key change, not transposition.
-c
- ipl(ivx,nnl(ivx)+1) = ibset(ipl(ivx,nnl(ivx)+1),28)
- lastisig = isig
- isig = nint(fnum)
- if (durq .eq. '-') isig = -isig
- isig = isig+idsig
- if (ismidi) call midievent('k',isig,0)
- else
-c
-c num1 .ne. 0, so transposition, so must be at beginning. isig came with K...
-c but was passed to pmxb through pmxtex.dat. isig0 comes from setup data
-c (signature before transposition). idsig must be added to future key changes.
-c
- jv = 0
- do while (jv .lt. nm)
- jv = jv+1
- iTransAmt(jv) = num1
- end do
- idsig = isig-isig0
- end if
- else
-c
-c Instrument specific transposition.
-c
- call GetiTransInfo(.false.,ibarcnt,lineq,iccount,
- * ibaroff,nbars,noinst)
-c
-c The sig parameters will have been set 1st time but that's OK
-c
- end if
- else if (charq .eq. '/') then
- if (btest(iornq(ivx,nnl(ivx)+1),26)) then
-c
-c There was a hardspace followed by end of block. Remove it from the hardspace
-c list, store with shifts instead, set special bit. This code also at '|'
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18)
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = udsp(nudsp)
- nudsp = nudsp-1
- iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26)
- end if
- call getchar(lineq,iccount,durq)
-c
-c Save ending note level:
-c
- if (ivx .le. nv) then
-c
-c This is the first line of music on this staff. If previous block had only 1
-c voice, save last pitch from line 1 of prev. block to line 2, in case a
-c 2nd line is started just below
-c
- if (.not.was2(iv)) ndlev(iv,2) = ndlev(iv,1)
- was2(iv) = .false.
- ndlev(iv,1) = lastlev
- else
-c
-c This is the 2nd line of music on this staff.
-c
- was2(iv) = .true.
- ndlev(iv,2) = lastlev
- end if
- if (durq .eq. ' ' .and. iv.eq.nv) then
-c
-c End of input block
-c
- loop = .false.
- else
-c
-c Start a new line of music
-c
- if (lenb0.ne.0 .and. firstgulp) lenbar = lenb0
- nbars = 0
- if (durq .eq. ' ') then
-c
-c New line of music is on next staff
-c
- iv = iv+1
- ivx = iv
- else
-c
-c durq must be 2nd '/'. New line of music is on same staff. Set up for it
-c
- ivx = nv+1
- do 23 iiv = 1 , nv
- if (nvmx(iiv) .eq. 2) ivx = ivx+1
-23 continue
- nvmx(iv) = 2
- ivmx(iv,2) = ivx
- itsofar(ivx) = 0
- nnl(ivx) = 0
- nfb(ivx) = 0
- nudoff(ivx) = 0
- ndotmv(ivx) = 0
- do 24 j = 1 , 200
- irest(ivx,j) = 0
- islur(ivx,j) = 0
- nacc(ivx,j) = 0
- iornq(ivx,j) = 0
- ipl(ivx,j) = 0
- mult(ivx,j) = 0
-24 continue
-c
-c Go back and lower the rests in voice "a" that don't have over-ridden heights
-c
- do 26 j = 1 , nnl(iv)
- if (btest(irest(iv,j),0) .and. nolev(iv,j).eq.0)
- * nolev(iv,j) = -4
-26 continue
- end if
- end if
- iccount = 128
- else if (charq .eq. 'X') then
-c
-c 3rd arg is only for termination of group shifts. Use "max" to avoid zero index,
-c which only happens for normal X at block start, and we took special measures to
-c keep group shifts for crossing block boundaries.
-c
- call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx))),
- * shifton,wheadpt,iornq(ivx,nnl(ivx)+1),ivx,
- * irest(ivx,nnl(ivx)+1),itsofar(ivx),0,0,0,' ',ndoub)
- else if (charq .eq. 'I') then
-c
-c Midi controls.
-c
- call getmidi(noinst,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar,
- * mtrdenl,nv,.false.)
- else if (charq .eq. 'M') then
-c
-c Macro action
-c
- call getchar(lineq,iccount,charq)
- if (index('RS',charq) .gt. 0) then
-c
-c Record or save a macro. Get the number of the macro.
-c
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,fnum)
- macnum = nint(fnum)
- macuse = ibset(macuse,macnum)
- if (charq .eq. 'R') then
- call mrec1(lineq,iccount,ndxm)
- else
-c
-c Save (Record but don't activate)
-c
-5 call mrec1(lineq,iccount,ndxm)
- if (mrecord) then
- call getbuf(lineq)
- iccount = 0
- go to 5
- end if
- iccount = iccount+ndxm+1
- end if
- else if (charq .eq. 'P') then
-c
-c Playback the macro
-c
- call getchar(lineq,iccount,charq)
- call readnum(lineq,iccount,durq,fnum)
- macnum = nint(fnum)
- icchold = iccount
- lnholdq = lineq
- iccount = 128
- ilmac = il1mac(macnum)
- mplay = .true.
- end if
- else if (index(',.',charq) .gt. 0) then
-c
-c Continued rhythmic shortcut
-c
- idotform = index('. ,',charq)
- if (idotform .eq. 1) then
-c
-c Check for start of forced beam on 2nd member of dotform=1 shortcut
-c
- if (fbon) then
- if (t1fb(ivx,nfb(ivx)).eq.itsofar(ivx))
- * t1fb(ivx,nfb(ivx)) =
- * t1fb(ivx,nfb(ivx))+nodur(ivx,nnl(ivx))/2
- end if
-c
-c Change duration of prior note
-c
- itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx))
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- end if
- idotform = idotform+1
- numnum = 1
- cdot = .true.
- go to 1
- end if
- return
- end
- subroutine getorn(lineq,iccount,iornq,iornq0,ornrpt,noffseg,
- * ip,ivx,noxtup,notcrd,nole)
-c
-c iornq: Main note. Do not alter if chord note, except turn on bit 23
-c iornq0: Store iorni + bit 23, in case of repeated ornaments
-c iorni: Internal use, 1st 21 bits of iornq or icrdorn, dep. on notcrd.
-c noffseg: horiz. offset for segno
-c nole: level of note w/ orn, used to ID the note/orn if there's a level shift.
-c
-
- common /comivxudorn/ivxudorn(63)
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comcb/ nbc,ibcdata(36)
- character*1 charq,durq
- character*128 lineq
- logical ornrpt,negseg,noxtup,notcrd
-c
-c Bits 0-13: (stmgx+Tupf._), 14: Down fermata, was F, 15: Trill w/o "tr", was U
-c 16-18 Editorial sharp, flat, natural "oes,f,n"; 19-20: >^, 21 ? for ed. accid.
-c
- call getchar(lineq,iccount,charq)
- if (index('bc',charq) .gt. 0) then
-c
-c caesura or breath, handle specially and exit. Set up data in ibcdata(1...nbc)
-c ivx(0-3,28), ip(4-12),
-c vshift (vshift+32 in bits 13-18),
-c hshift (nint(10*vshift)+128 in bits 19-26)
-c bit 27 = 0 if caesura, 1 if breath
-c bit 28: 5th bit of ivx
-c
- iornq = ibset(iornq,28)
- nbc = nbc+1
-c ibcdata(nbc) = ivx+16*ip
- ibcdata(nbc) = mod(ivx,16)+16*ip
- if (ivx.ge.16) ibcdata(nbc) = ibset(ibcdata(nbc),28)
- if (charq .eq. 'b') ibcdata(nbc) = ibset(ibcdata(nbc),27)
- call getchar(lineq,iccount,durq)
- if (index('+-',durq) .gt. 0) then
-c
-c We have a vertical shift, get it
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- if (durq .eq. '-') fnum=-fnum
- call setbits(ibcdata(nbc),6,13,nint(32+fnum))
- if (index('+-',charq) .gt. 0) then
-c
-c Horizontal shift, get it
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (charq .eq. '-') fnum=-fnum
- call setbits(ibcdata(nbc),8,19,nint(10*fnum)+128)
- end if
- end if
- return
- end if
-c
-c Set signal on main note that some note at this time has ornament. ONLY used
-c in beamstrt to activate further tests for whether ihornb is needed.
-c
- iornq = ibset(iornq,23)
-c
-c Isolate 21 bits defining exisiting ornaments
-c
- if (notcrd) then
-c iorni = iand(4194303,iornq)
-c iorni = iand(541065215,iornq)
- iorni = iand(1614807039,iornq)
- else
- iorni = iand(4194303,icrdorn(ncrd))
- end if
-c korn = index('stmgx+Tupf._)e:XXX>^',charq)
- korn = index('stmgx+Tupf._)e:XXX>^XXXXXXXXCG',charq)
- if (korn .ne. 15) iorni = ibset(iorni,korn)
-c
-c Note that korn=0 => charq='(', and we set bit 0. if "e" (14), alter later
-c as follows: korn=16-18 for sfn, and or 21 for bare ?.
-c When this if-block is done, korn will = bit# of actual ornament (unless "?").
-c
- if (korn .eq. 15) then
-c
-cc Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-20 prev iornq
-cc Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21 prev iornq
-c Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21,29 prev iornq
-c
-c iorni = ior(iorni,iand(iornq0,1638383))
-c iorni = ior(iorni,iand(iornq0,3735535))
-c iorni = ior(iorni,iand(iornq0,540606447))
- iorni = ior(iorni,iand(iornq0,1614348271))
- ornrpt = .false.
- call getchar(lineq,iccount,durq)
-c
-c durq will be ' '
-c
- else if (korn .eq. 14) then
-c
-c Editorial accidental
-c
- call getchar(lineq,iccount,durq)
-c korn = 15+index('sfn',durq)
- korn = 15+index('sfn?',durq)
- if (korn .eq. 19) korn=21
- iorni = ibset(ibclr(iorni,14),korn)
- call getchar(lineq,iccount,durq)
- if (durq .eq. '?') then
-c
-c This is "oe[s|f|n]?". Set 21st bit also.
-c
- iorni = ibset(iorni,21)
- korn = korn+6
- call getchar(lineq,iccount,durq)
- end if
-c iorni = ibset(ibclr(iorni,14),korn)
- else if (korn.eq.4 .and. noxtup) then
-c
-c segno. Check in pmxa for just 1/block & notcrd. Get horiz. offset in points
-c
- noffseg = 0
- negseg = .false.
- call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
-c
-c Segno shift is specified
-c
- if (durq .eq. '-') then
- negseg = .true.
- call getchar(lineq,iccount,durq)
- end if
- call readnum(lineq,iccount,durq,fnum)
- noffseg = int(fnum)
- if (negseg) noffseg = -noffseg
- end if
- else if (korn .eq. 7) then
-c
-c Trill. Check in pmxa for notcrd. Default is 1 noteskip long, with "tr"
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = ip
- xnsktr(ntrill) = 1.
- call getchar(lineq,iccount,durq)
- if (durq .eq. 't') then
-c
-c Convert to new internal symbol for non-'"tr" trill
-c
- korn = 15
- iorni = ibset(ibclr(iorni,7),15)
- call getchar(lineq,iccount,durq)
- end if
- if (index('0123456789.',durq) .gt. 0) then
-c
-c We have a number for the length
-c
- call readnum(lineq,iccount,durq,xnsktr(ntrill))
- end if
- else if (korn.eq.10 .and. noxtup) then
-c
-c Fermata
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'd') then
- korn = 14
- iorni = ibset(ibclr(iorni,10),14)
- call getchar(lineq,iccount,durq)
- end if
- else
- call getchar(lineq,iccount,durq)
- end if
- if (index('+- :',durq) .eq. 0) then
- print*,'Unexpected character at end of ornament: ',durq
- call stop1()
- end if
- if (index('+-',durq) .gt. 0) then
-c
-c Shift ornament up or down
-c
- nudorn = nudorn+1
-c
-c Set bit 25 in iorni as a signal. This may not really be necessary.
-c
- iorni = ibset(iorni,25)
-c
-c Assemble info to put in kudorn(nudorn) Bits 0-7:ip, 8-11:ivx, 12-18:nolev,
-c 19-24: type of ornament to be shifted, 25-30: shift+32, 31:h-shft present
-c
- xofforn = 44-ichar(durq)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iofforn = nint(xofforn*fnum)
- kudorn(nudorn) = ip+ishft(mod(ivx,16),8)+ishft(nole,12)
- * +ishft(korn,19)+ishft(iofforn+32,25)
- ivxudorn(nudorn) = ivx
- if (index('+-',durq) .gt. 0) then
-c
-c Horizontal shift
-c
- kudorn(nudorn) = ibset(kudorn(nudorn),31)
- xofforn = 44-ichar(durq)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
-c 141226 ornhshft(nudorn) = nint(xofforn*fnum)
- ornhshft(nudorn) = xofforn*fnum
- end if
- else if (durq .eq. ':') then
-c
-c Turn on repeated ornaments
-c
- ornrpt = .true.
-c
-c Save the ornament value just set
-c
- iornq0 = iorni
- end if
- if (notcrd) then
- iornq = ior(iornq,iorni)
- else
- icrdorn(ncrd) = ior(icrdorn(ncrd),iorni)
- end if
- return
- end
- subroutine getpmxmod(global,includeq)
-c
-c If global=.true., checks for environment variable with path to pmx.mod.
-c Then, if variable exists and points to pmx.mod, insert lines from
-c pmx.mod into buffer
-c If global=.false., checks for existence of includeq and uses it.
-c
-c lenbuf0 = total length of bufq on entry
-c lbuf(i) = length of line (i)
-c nlbuf = number of lines stored in bufq
-c ilbuf = index of first line after setup stuff (on entry). In general, index of
-c next line to be sucked from buffer.
-c ilbufmod = counter for lines in pmx.mod as they are grabbed.
-c Starts at ilbuf. Points to position of next line after
-c pmx.mod stuff in bufq on exiting loop 1
-c ilbuff = transient counter for shifting operations
-c ipbuf = on entry, points to last character in setup stuff. In general, points
-c to last character of most recent line sucked from buffer.
-c ipbufmod = points to last character of most recent inserted line
-c from pmx.mod
-c
- parameter (maxblks=9600,nm=24)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,fbon,issegno,isheadr,isvolt
- character*(*)includeq
- character*80 pmxmoddirq
- character*128 lnholdq
- character*131072 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- logical fexist,global
- line1pmxmod = ilbuf
- if (.not.global) then
- inquire(file=includeq,EXIST=fexist)
-c
-c Transfer includeq to temporary char variable with known length
-c
- pmxmoddirq = includeq
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- print*
- write(15,'()')
- if (.not.fexist) then
- call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq)
- * //', checking further.')
-c
-c File named includeq doesn't not exist. Get directory from PMXMODDIR and
-c see if it's there
-c
- call getenv('PMXMODDIR',pmxmoddirq)
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- if (lpmxmoddirq. gt. 0) then
- pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//includeq
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- else
- call printl(
- * 'No other directory defined by PMXMODDIR, stopping')
- call stop1()
- end if
- inquire(file=pmxmoddirq,EXIST=fexist)
- if (.not.fexist) then
- call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq)
- * //', stopping.')
- call stop1()
- end if
- end if
- call printl('Opening normal include file '
- * //pmxmoddirq(1:lpmxmoddirq))
- open(18,file=pmxmoddirq)
- else
-c
-c Check for existence of pmx.mod
-c
- call getenv('PMXMODDIR',pmxmoddirq)
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- if (lpmxmoddirq .eq. 0) return
- pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//'pmx.mod'
- lpmxmoddirq = lpmxmoddirq+7
- inquire(file=pmxmoddirq,EXIST=fexist)
- if (.not.fexist) return
- call printl('Opening global include file '
- * //pmxmoddirq(1:lpmxmoddirq))
- open(18,file=pmxmoddirq(1:lpmxmoddirq))
- end if
- call printl('Adding include data')
-c
-c Read lines in from pmx.mod one at a time
-c
- ipbufmod = ipbuf
- lenbufmod = lenbuf0
- do 1 ilbufmod = ilbuf , maxblks
- read(18,'(a)',end=3)lnholdq
-c
-c A line was read. Slide all existing lengths from here forward ahead by 1
-c
- do 2 ilbuff = nlbuf , ilbufmod , -1
- lbuf(ilbuff+1) = lbuf(ilbuff)
-2 continue
-c
-c Get length of line from include file
-c
- lenmodline = lenstr(lnholdq,128)
- if (lenmodline .eq. 0) then
-c
-c Blank line. Make it a single blank with length 1
-c
- lenmodline = 1
- lnholdq = ' '
- end if
- lbuf(ilbufmod) = lenmodline
- call printl(lnholdq(1:lenmodline))
-c
-c Insert new stuff into bufq
-c
- bufq = bufq(1:ipbufmod)//lnholdq(1:lenmodline)//
- * bufq(ipbufmod+1:lenbufmod)
-c
-c Update internal parameters
-c
- ipbufmod = ipbufmod+lbuf(ilbufmod)
- lenbufmod = lenbufmod+lbuf(ilbufmod)
- nlbuf = nlbuf+1
-1 continue
-3 continue
- call printl('Closing '//pmxmoddirq(1:lpmxmoddirq))
- close(18)
- linesinpmxmod = linesinpmxmod+ilbufmod-ilbuf
- lenbuf0 = lenbufmod
-c
-c Fix Andre's error reporting problem 101211 leading to log(neg#) due
-c to nline being 2 bigger than it should be
-c
- nline=nline-2
-c
- return
- end
- subroutine getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
- * xmtrnum0,npages,nsyst,musicsize,fracindent,istype0,
- * inameq,clefq,sepsymq,pathnameq,lpath,isig0)
- parameter (nm=24)
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- character*1 clefq(nm),sepsymq(nm)
- character*40 pathnameq
- character*79 inameq(nm)
- character*128 lineq
- logical istype0,newway,rename
- common /commidisig/ midisig
-c
-c Get the first line
-c
- iccount = 0
-9 call getbuf(lineq)
- if (lineq(1:1) .eq. '%') go to 9
- istype0 = lineq(1:3).eq.'---'
- if (istype0) then
-c
-c Have TeX input until next line that starts with '---'. Save in scratch.
-c
- open(17,status='SCRATCH')
-3 call getbuf(lineq)
- if (lineq(1:3) .ne. '---') then
- write(17,'(a)')lineq
- go to 3
- end if
-c
-c Force a new line read on first call to readin
-c
- iccount = 128
- end if
-c
-c Here, lineq is first line w/ numerical setup data.
-c
- nv = nint(readin(lineq,iccount,nline))
- noinst = nint(readin(lineq,iccount,nline))
- newway = noinst.le.0
- if (newway) noinst = -noinst
- do 2 iinst = 1 , noinst
-c
-c Seve # of staves per inst in case later drop some inst's.
-c
- if (newway) then
-c
-c Read in nvi for each instrument
-c
- nsperi(iinst) = nint(readin(lineq,iccount,nline))
- else if (iinst .gt. 1 ) then
- nsperi(iinst) = 1
- else
- nsperi(iinst) = nv-noinst+1
- end if
- iiorig(iinst) = iinst
- nspern(iinst) = nsperi(iinst)
-2 continue
- mtrnuml = nint(readin(lineq,iccount,nline))
- mtrdenl = nint(readin(lineq,iccount,nline))
-cc
-cc Kluge to make mtrdenl work
-cc
-c if (mtrdenl .eq. 1) then
-c mtrdenl = 2
-c mtrnuml = mtrnuml*2
-c end if
- mtrnmp = nint(readin(lineq,iccount,nline))
- mtrdnp = nint(readin(lineq,iccount,nline))
- xmtrnum0 = readin(lineq,iccount,nline)
-c
-c Original key sig (before any trnasposition) in next position. Transposed
-c sig for topfile was transferred thru pmxtex.dat. Need isig0 for key
-c changes if transposed.
-c
- isig0 = nint(readin(lineq,iccount,nline))
-c 130316
-c do 11 iinst = 1 , noinst
-c midisig(iinst) = isig0
- midisig = isig0
-c11 continue
- npages = nint(readin(lineq,iccount,nline))
- nsyst = nint(readin(lineq,iccount,nline))
- musicsize = nint(readin(lineq,iccount,nline))
- fracindent = readin(lineq,iccount,nline)
-c
-c Next noinst non-comment lines are names of instruments.
-c
- do 4 i = 1 , noinst
-5 call getbuf(inameq(i))
- if (inameq(i)(1:1) .eq. '%') go to 5
-4 continue
-c
-c Next non-comment line has nv clef names
-c
-6 call getbuf(lineq)
- if (lineq(1:1) .eq. '%') go to 6
- iv = 0
- nvsofar = 0
- do 1 jinst = 1 , noinst
- nvsofar = nvsofar+nsperi(jinst)
- do 10 ivi = 1 , nsperi(jinst)
- iv = iv+1
- clefq(iv) = lineq(iv:iv)
- if (iv .eq. nvsofar) then
- sepsymq(iv) = '&'
- else
- sepsymq(iv) = '|'
- end if
-10 continue
-1 continue
-c
-c Mext non-comment line has path name
-c
-8 call getbuf(pathnameq)
- if (pathnameq(1:1) .eq. '%') go to 8
- lpath = index(pathnameq,' ')-1
-c
-c 160130 Replace '\' by '/'
-c
-12 ipos = index(pathnameq,'\')
- if (ipos .gt. 0) then
- pathnameq(ipos:ipos)='/'
-c print*,'Changed pathname to ',pathnameq(1:lpath)
- go to 12
- end if
- return
- end
- function getsquez(n,ntot,space,tnote,to)
- real*4 tnote(600),to(600)
- common /comtol/ tol
-c
-c Get the squez factor by checking space against tgovern=minimum duration
-c of all notes sounding at time of n-th note in the list.
-c The starting time of base increment is to(n) and ending time is to(n)+space
-c Sounding notes are those that start at or before to(n) .and. end at or
-c after tend=to(n)+space
-c Since notes are ordered by increasing start times, as soon as we find one
-c that starts too late, we are done checking.
-c
- tgovern = 1000.
- tend = to(n)+space
- do 1 in = 1 , ntot
-c
-c Since to() is ordered by start times, exit loop after first note that
-c starts later than note of interest.
-c
- if (to(in) .gt. to(n)+tol) go to 2
- if (to(in)+tnote(in) .gt. tend-tol) then
-c
-c If here, this note overlaps and must be tested.
-c
- tgovern = min(tgovern,tnote(in))
- end if
-1 continue
-2 continue
- getsquez = space/tgovern
- return
- end
- subroutine getx(lineq,iccount,irest,shifton,wheadpt,iornq1,ivx,
- * irest1,itsofar,ntup,itup,nnodur,dotq,ndoub)
- parameter(nm=24)
-c
-c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol.
-c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols.
-c Since during getnote phase time is integer itsofar, which is not updated
-c during xtups, we use itup and ntup to get actual time. On entry, ntup=0 if
-c not in xtup.
-c
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- logical shifton,colon,ess,number
- character*128 lineq
- character*1 charq,durq,dotq
- colon = .false.
- ess = .false.
- number = .false.
- nextbl = iccount+index(lineq(iccount:128),' ')-1
- if (index(lineq(iccount:nextbl),'P') .gt. 0) then
-c
-c "Parts only", ignore entire symbol
-c
- iccount = nextbl
- return
- end if
-1 call getchar(lineq,iccount,charq)
- if (charq.eq.'B') then
-c
-c "Both parts and score," ignore character
-c
- go to 1
- else if (charq .eq. ':') then
- colon = .true.
- go to 1
- else if (charq .eq. 'S') then
- ess = .true.
- go to 1
- else if (index('+-.0123456789',charq) .gt. 0) then
- number = .true.
- if (charq.eq.'-') iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (charq .eq. '-') fnum = -fnum
- if (durq .ne. 'p') then
- fnum = fnum*wheadpt
- iccount = iccount-1
- end if
- go to 1
- end if
-c
-c charq must be blank, so done parsing
-c
- if (.not.ess .and. .not.colon) then
-c
-c Ordinary hardspace. Goes before next note.
-c (Later, at "|" or "/", check for presence and switch to udoff if there!)
-c
- nudsp = nudsp+1
- iornq1 = ibset(iornq1,26)
- udsp(nudsp) = fnum
- tudsp(nudsp) = itsofar
- if (ntup .gt. 0) tudsp(nudsp) = tudsp(nudsp)
-c * +float(itup-1)/ntup*ifnodur(nnodur,dotq)
- * +float(itup-1+ndoub)/ntup*ifnodur(nnodur,dotq)
- else if (.not.number) then
-c
-c Must be "X:" End a group offset.
-c
- irest = ibset(irest,17)
- shifton = .false.
- return
- else
-c
-c Only other possibility is start offset, "S" for single, ':' for multiple
-c
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = fnum
- if (ess) then
- irest1 = ibset(irest1,15)
- else
- irest1 = ibset(irest1,16)
- shifton = .true.
- end if
- end if
- return
- end
- function i1fnodur(idur,dotq)
- character*1 dotq
- if (idur .eq. 6) then
- i1fnodur=1
- else if (idur .eq. 3) then
- i1fnodur=2
- else if (idur .eq. 1) then
- i1fnodur=4
- else if (idur .eq. 8) then
- i1fnodur=8
- else if (idur .eq. 4) then
- i1fnodur=16
- else if (idur .eq. 2) then
- i1fnodur=32
- else if (idur .eq. 0) then
- i1fnodur=64
- else if (idur .eq. 16) then
-c
-c Only used for denominator of time signatures, not for notes
-c
- i1fnodur=4
- else if (idur .eq. 9) then
- i1fnodur = 128
- else
- print*
- print*,'You entered an invalid note-length value:',idur
- call stop1()
- end if
- if (dotq .eq. 'd') i1fnodur = i1fnodur*3/2
- return
- end
-c integer*4 function longi(ishort)
-c integer*2 ishort
-c longi = ishort
-c return
-c end
- function iashft(nacc)
- integer*4 ias(6)
- data ias /-1,1,0,0,-2,2/
- iashft = ias(nacc)
- return
- end
- function ifnodur(idur,dotq)
- character*1 dotq
- if (idur .eq. 6) then
- ifnodur=1
- else if (idur .eq. 3)then
- ifnodur=2
- else if(idur .eq. 1) then
- ifnodur=4
- else if(idur .eq. 8) then
- ifnodur=8
- else if(idur .eq. 4) then
- ifnodur=16
- else if(idur .eq. 2) then
- ifnodur=32
- else if(idur .eq. 0) then
- ifnodur=64
- else if(idur .eq. 9) then
- ifnodur=128
- else if (idur .eq. 16) then
-c
-c Only used for denominator of time signatures, not for notes
-c
- ifnodur=4
- else
- print*,'You entered an invalid note value'
- stop
- end if
- if (dotq .eq. 'd') ifnodur = ifnodur*3/2
- return
- end
- function ifnolev(noq,oct,ntrans)
- character*1 noq
- integer oct
- ifnolev = 7*oct+mod(ichar(noq)-92,7)+1+ntrans
- return
- end
-c subroutine report(nsdat,isdat1,isdat2)
-c integer*4 isdat1(202),isdat2(202)
-c write(*,'(a)')
-c * ' isd on? iv kv ip id ud1 ud2 ndx ivo iho lev crd lhd rhd'
-c do 1 isdat = 1 , nsdat
-c isdata = isdat1(isdat)
-c ionoff = igetbits(isdata,1,11)
-cc iv = iand(7,isdata)
-c iv = igetbits(isdata,5,13)
-c kv = igetbits(isdata,1,12)+1
-c ip = igetbits(isdata,8,3)
-c idcode = igetbits(isdata,7,19)
-c iud1 = igetbits(isdata,1,26)
-c iud2 = igetbits(isdata,1,27)
-c ndxslur = igetbits(isdata,4,28)
-c isdatb = isdat2(isdat)
-c ivo = igetbits(isdatb,6,6)-32
-c iho = igetbits(isdatb,7,12)-64
-c lev = igetbits(isdatb,7,19)
-c icrd = igetbits(isdatb,1,0)
-c lhd = igetbits(isdatb,1,1)
-c irhd = igetbits(isdatb,7,2)
-c write(*,'(17i4)')isdat,ionoff,iv,kv,ip,idcode,iud1,iud2,ndxslur,
-c * ivo,iho,lev,icrd,lhd,irhd
-c1 continue
-c print*
-c return
-c end
- function igetbits(isdata,iwidbit,ishift)
-c
-c Extracts integer given by iwidbit bits of isdata, shifted by ishift, and
-c then added to ioff
-c
- igetbits = iand(2**iwidbit-1,ishft(isdata,-ishift))
- return
- end
- function igetvarlen(mmidi,icm,imidi,nbytes)
-c
-c Gets variable-length integer starting in mmidi at imidi+1. Returns nbytes.
-c
- parameter (nm=24,mv=24576)
- integer*2 mmidi(0:nm,mv)
- igetvarlen = 0
- do 1 nbytes = 1 , 4
- igetvarlen = 128*igetvarlen
- * +iand(127,mmidi(icm,imidi+nbytes))
- if (.not.btest(mmidi(icm,imidi+nbytes),7)) return
-1 continue
- print*,'Messup in igetvarlen'
- call stop1()
- end
- logical function isdotted(nodur,ivx,ip)
- parameter (nm=24)
-c
-c Function returns true if note is dotted or double-dotted.
-c Return false for any xtuplet.
-c
- common /comtol/ tol
- integer*4 nodur(nm,200)
- if (nodur(ivx,ip) .eq. 0) then
- isdotted = .false.
- return
- else if (ip .gt. 1) then
- if (nodur(ivx,ip-1) .eq. 0) then
- isdotted = .false.
- return
- end if
- end if
-c
-c Ruled out all xtups, so is dotted or double-dotted if not a power of 2.
-c
- isdotted =
- * mod(alog(float(nodur(ivx,ip)))/.69314718+.5*tol,1.) .gt. tol
- return
- end
- function isetvarlen(idur,nbytes)
- isetvarlen = 0
- itemp = idur
- do 1 nbytes = 1 , 4
- isetvarlen = isetvarlen + iand(itemp,127)*256**(nbytes-1)
- itemp = ishft(itemp,-7)
- if (itemp .gt. 0) then
- isetvarlen = isetvarlen+2**(8*nbytes+7)
- else
- return
- end if
-1 continue
- print*,'Problem in fn. isetvarlen'
- call stop1()
- end
- subroutine istring(i,string,len)
-c
-c Returns string with integer only if length is 1, otherwise enclosed in
-c brackets.
-c
- character*(*) string
- if (i .ne. 0) then
- len = alog10(abs(i)*1.0001)+1
- if (i .lt. 0) len = len+1
- else
- string = '0'
- len = 1
- return
- end if
- if (len .eq. 1) then
- string = char(48+i)
- else
- string = '{'
- write(string(2:1+len),'(i'//char(48+len)//')')i
- string = string(1:len+1)//'}'
- len = len+2
- end if
- return
- end
- function lenstr(string,n)
- character*(*) string
- do 1 lenstr = n , 1 , -1
- if (string(lenstr:lenstr) .ne. ' ') return
-1 continue
- lenstr = 0
- return
- end
- function levrn(nolev,irest,iud,ncm,mult)
-c
-c Used for placing numbers in xtups. Returns note level if not a rest,
-c else level of top or bottom of rest symbol opposite beam. iud=-1 for upstm.
-c
- logical btest
- if (.not.btest(irest,0)) then
- levrn = nolev
- else
-c
-c Restlevel is -4, 0, 2 or 100+offset. First get offset from 1-voice default.
-c
- if (mult .gt. 0) then
- if (mult .eq. 2) then
- ioff = -1+2*iud
- else if (mult .ne. 4) then
- ioff = iud*mult
- else
- ioff = 1+4*iud
- end if
- else
-c
-c May need to futz with this later for non-beamed xtups (quarter, half rests)
-c
- ioff = iud*2
- end if
- levrn = mod(nolev+20,100)-20+ncm+ioff
- endif
- return
- end
- function lfmt1(x)
-c
-c Computes total length of an "f" format with one decimal place.
-c First round to nearest 0.1
-c
- if (abs(x) .lt. .001) then
- lfmt1 = 2
- else
- y = sign(.1*int(10*abs(x)+.5),x)
- lfmt1 = int(log10(1000*abs(y)+.001))
- if (y .lt. 0) lfmt1 = lfmt1+1
- end if
- return
- end
- subroutine LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat,
- * ispstie,sepsymq)
- parameter (nm=24)
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comoct/ noctup
- integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202)
- logical fontslur,WrotePsslurDefaults,btest,upslur,ispstie,tie
- character*1 udq,chax,sepsymq(nm)
- character*8 noteq
- character*128 notexq
-c
-c This is called twice from pmxb after having input an entire block, before
-c making a bar that starts a new system. So nsdat reflects all slur starts
-c and stops in new block, while listslur, which is only set when bars are
-c made, reflects only open slurs from the old block. So we must check
-c listslur to find open ties, not all nsdat.
-c First of two calls (ispstie=.false. on entry) terminates tie at end of line.
-c Second (ispstie=.true. on entry) restarts tie at start of new line. Only
-c need data from original tie-start for both of these. Tie/slur data from
-c closing of full tie are not used except for shape alterations.
-c
-c do 1 ndx = 0 , 11
- do 1 ndx = 0 , 23
- if (btest(listslur,ndx)) then
-c
-c Slur or tie with index ndx is open. Find the one with right ndxb, see if tie
-c
- do 2 isdat = 1 , nsdat
-c if (igetbits(isdat1(isdat),4,28) .ne. ndx) go to 2 ! Wrong index
- if (igetbits(isdat1(isdat),4,28)
- * +16*igetbits(isdat1(isdat),1,18) .ne. ndx) go to 2 ! Wrong index
- if (.not.btest(isdat1(isdat),11)) go to 2 ! Bypass if stop
- if (btest(isdat2(isdat),3)) go to 3 ! "st"
- idcode = igetbits(isdat1(isdat),7,19)
- if (idcode.eq.1) go to 3 ! "t"
- tie = .false.
- go to 5
-2 continue
- end if
- go to 1
-3 continue
- tie = .true.
-5 continue
-c
-c A slur or tie is open, with index ndx
-c
- iv = igetbits(isdat1(isdat),5,13)
- kv = igetbits(isdat1(isdat),1,12)+1
- udq = 'd'
- if (btest(isdat1(isdat),27)) udq='u'
- notexq = chax(92)//'znotes'
- lnote = 7
- do 4 iiv = 1 , iv-1
- notexq = notexq(1:lnote)//sepsymq(iiv)
- lnote = lnote+1
-4 continue
- if (kv .eq. 2) then
- notexq = notexq(1:lnote)//chax(92)//'nextvoice'
- lnote = lnote+10
- end if
-c
-c Compute horiz and vert offsets
-c
-c nolev = igetbits(isdat2(isdat),7,19)
- islhgt = igetbits(isdat3(isdat),8,14)
- ilb12 = 0
- if (ispstie) ilb12 = 1
- ivoff = igetbits(isdat4(isdat),6,ilb12*16)-32
- if (ivoff .eq. -32) ivoff = 0
-C nolev = nolev+ivoff
- islhgt = islhgt+ivoff
- ihoff = (igetbits(isdat4(isdat),7,ilb12*16+6)-64) ! This is 10X hoff
- if (ihoff .eq. -64) ihoff = 0
-c
-c Add starting stuff for command
-c
- if (.not.ispstie) then ! End 1st segment
- notexq = notexq(1:lnote)//chax(92)//'roffset{'
- lnote = lnote+9
-c hoff = ihoff*.1-.5
-c hoff = ihoff*.1-.8
- hoff = ihoff*.1-.4
- if (hoff .lt. 0) then
- hoff = -hoff
- notexq = notexq(1:lnote)//'-'
- lnote = lnote+1
- end if
- call writflot(hoff,notexq,lnote)
- notexq = notexq(1:lnote)//'}{'
- lnote = lnote+2
- else
- notexq = notexq(1:lnote)//chax(92)//'off{-'
- * //chax(92)//'afterruleskip}'
- lnote = lnote+21
-c
-c 091025 add dotting for 2nd segment if needed
-c
- if (btest(isdat2(isdat),4)) then
- notexq = chax(92)//'dotted'//notexq(1:lnote)
- lnote = lnote+7
- end if
- end if
- if (ispstie .and. tie) then
- notexq = notexq(1:lnote)//chax(92)//'tieforis'//udq
- lnote = lnote+10
- end if
- if (btest(isdat3(isdat),0)) then
-c
-c Curvature tweak on termination of 1st seg
-c
- imid = igetbits(isdat3(isdat),6,2)-32
-c
-c Invoke macro (from pmx.tex) that redefines \tslur as r'qd. mapping:
-c Abs(imid) Postscript slur type
-c 1 f
-c 4 h
-c 5 H
-c 6 HH
-c
- notexq = notexq(1:lnote)//chax(92)//'psforts'//chax(48+imid)
- lnote = lnote+9
-c
-c Zero out the flag in case there's a different curv on term of 2nd,
-c
- isdat3(isdat) = ibclr(isdat3(isdat),0)
- end if
-c
-c Add the command name
-c
- if (ispstie) then
- notexq = notexq(1:lnote)//chax(92)//'is'//udq
- lnote = lnote+4
- else if (tie) then
- notexq = notexq(1:lnote)//chax(92)//'ttie'
- lnote = lnote+5
- else
- notexq = notexq(1:lnote)//chax(92)//'tslur'
- lnote = lnote+6
- end if
-c
-c Add index
-c
-c if (11-ndx .lt. 10) then
-c notexq = notexq(1:lnote)//chax(59-ndx)
-c lnote = lnote+1
-c else
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndx)//'}'
-c lnote = lnote+4
-c end if
- if (23-ndx .lt. 10) then
- notexq = notexq(1:lnote)//chax(71-ndx)
- lnote = lnote+1
- else if (23-ndx .lt. 20) then
- notexq = notexq(1:lnote)//'{1'//chax(61-ndx)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndx)//'}'
- lnote = lnote+4
- end if
- if (ispstie .or. .not.tie) then
-c
-c Add note name for slur height
-c
- noctup = 0
- ncm = igetbits(isdat3(isdat),8,22)
- if (ncm .eq. 23) noctup = -2
-c call notefq(noteq,lnoten,nolev,ncm)
- call notefq(noteq,lnoten,islhgt,ncm)
- notexq = notexq(1:lnote)//'{'//noteq(1:lnoten)//'}'
- lnote = lnote+1+lnoten+1
- end if
- if (ispstie) then
-c
-c Horizontal shift start of new thing
-c
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
-c ihoff = ihoff-13
- if (tie) then
- ihoff = ihoff-12
- else
- ihoff = ihoff-7
- end if
- if (ihoff .lt. 0) then
- ihoff = -ihoff
- notexq = notexq(1:lnote)//'-'
- lnote = lnote+1
- end if
- call writflot(ihoff*.1,notexq,lnote)
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
-c
-c Add closing stuff
-c
- if (ispstie) then
- notexq = notexq(1:lnote)//chax(92)//'off{'
- * //chax(92)//'afterruleskip}'
- lnote = lnote+20
- else
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- notexq = notexq(1:lnote)//chax(92)//'en%'
- lnote = lnote+4
- write(11,'(a)')notexq(1:lnote)
-1 continue
- ispstie = .not.ispstie
- return
- end
- subroutine littex(islur,nnl,iv,topmods,lineq,iccount)
- parameter (nm=24)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- integer islur(nm,200)
- logical topmods
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,merge
- character*128 lineq,litq
- character*20 voltxtq
- character*1 durq,chax
- merge = .false.
- if (nlit .gt. 0) then
- merge = iv.eq.ivlit(nlit) .and. nnl.eq.iplit(nlit)
- end if
- nlit = nlit+1
- ivlit(nlit) = iv
- iplit(nlit) = nnl
- itype = 1
-17 call getchar(lineq,iccount,durq)
- if (durq .eq. chax(92)) then
- itype=itype+1
- go to 17
- end if
- litq(nlit) = chax(92)//durq
- lenlit(nlit) = 2
-18 call getchar(lineq,iccount,durq)
- if (durq.eq.chax(92)) then
- call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
-c
-c Starting a new tex command within the string
-c
- litq(nlit) = litq(nlit)(1:lenlit(nlit))//chax(92)//durq
- lenlit(nlit) = lenlit(nlit)+2
- go to 18
- end if
- else
- litq(nlit) = litq(nlit)(1:lenlit(nlit))//durq
- lenlit(nlit) = lenlit(nlit)+1
- go to 18
- end if
-c
-c If here, just read backslash-blank so string is done
-c
- if (itype .eq. 1) then
- islur(iv,nnl) = ibset(islur(iv,nnl),16)
- if (merge) then
-c
-c There are 2 separate strings on the same note, so merge them.
-c
- nlit = nlit-1
- litq(nlit) = litq(nlit)(1:lenlit(nlit))
- * //litq(nlit+1)(1:lenlit(nlit+1))
- lenlit(nlit) = lenlit(nlit)+lenlit(nlit+1)
- if (lenlit(nlit) .gt. 128) then
- print*
- print*,
- * 'Merged type-1 TeX strings longer than 128 characters'
- write(15,'(/,a)')
- * 'Merged type-1 TeX strings longer than 128 characters'
- call stop1()
- end if
- end if
- else
-c
-c Type 2 or 3.
-c
- if (itype .eq. 3) then
-c
-c Write the string NOW
-c
- if (islast)
- * write(11,'(a)')litq(nlit)(1:lenlit(nlit))//'%'
- else
-c
-c Must go at top
-c
- if (.not.topmods) then
- topmods = .true.
- open(16,status='SCRATCH')
- end if
-c
-c Must write '%' here rather than later, in case string ends with blank.
-c
- write(16,'(a)')litq(nlit)(1:lenlit(nlit))//'%'
- end if
- nlit = nlit-1
- end if
- return
- end
- function llen(strq,n)
- character*129 strq
- do 1 llen = n , 0 , -1
- if (strq(llen:llen) .ne. ' ') return
-1 continue
- end
- function log2(n)
-c
-c 5/25/08 Modify to allow more slurs
-c
-c log2 = alog(1.*n)/0.6931472+.0001
-c log2 = dlog(1.d0*n)/0.693147181d0+.00000001d0
- log2 = dlog(1.d0*n)/0.693147181d0+.00000002d0
- return
- end
- subroutine logbeam(numnew,nip1,nip2)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*1 ulq,sepsymq,sq,ulfq,ulfbq
- logical beamon,firstgulp,figbass,figchk,isfig,isxtup,btest,
- * autofbon
- ibm1(ivx,numnew) = nip1
- ibm2(ivx,numnew) = nip2
- numnow = numnew
- if (numnew .gt. 1) then
-c
-c If it starts before any others, must put it in order
-c
- do 11 ib = numnew-1 , 1 , -1
- if (ibm1(ivx,ib) .lt. nip1) go to 12
- ibm1(ivx,ib+1) = ibm1(ivx,ib)
- ibm2(ivx,ib+1) = ibm2(ivx,ib)
- ulq(ivx,ib+1) = ulq(ivx,ib)
- ibm1(ivx,ib) = nip1
- ibm2(ivx,ib) = nip2
- numnow = ib
-11 continue
-12 continue
- end if
- sum = 0.
-c
-c Beam has non-xtup within
-c
- nrests = 0
- isxtup = .false.
- do 9 iip = nip1 , nip2
- if (btest(islur(ivx,nip1),21)) then
-c
-c Forced multiplicity
-c
- call setbits(mult(ivx,iip),4,0,
- * igetbits(islur(ivx,nip1),3,22)+8)
- else if (.not.isxtup) then
- if (nodur(ivx,iip) .gt. 0) then
- call setbits(mult(ivx,iip),4,0,4-log2(nodur(ivx,iip))+8)
- else
-c
-c Start xtup within forced beam
-c
- isxtup = .true.
- iip1 = iip
- end if
- else if (isxtup .and. nodur(ivx,iip).gt.0) then
-c
-c End of xtup within forced beam. Must count doubled notes
-c
- ndoub = 0
- do 1 iiip = iip1 , iip
- if (btest(nacc(ivx,iiip),18)) ndoub = ndoub+1
-1 continue
- multx = int(10.5+2.929+(0.952*alog(1.+iip-iip1+ndoub)-
- * alog(nodur(ivx,iip)/2.))/0.69315)-10
- do 74 iiip = iip1 , iip
- call setbits(mult(ivx,iiip),4,0,multx+8)
-c
-c Note the following still works after making mult only the 1st 4 bits.
-c
- if (btest(nacc(ivx,iiip),18))
- * mult(ivx,iiip) = mult(ivx,iiip)-1
- if (btest(nacc(ivx,iiip),19)) then
- mult(ivx,iiip) = mult(ivx,iiip)+1
- else if (iiip .gt. 1) then
- if (btest(nacc(ivx,iiip-1),19))
- * mult(ivx,iiip) = mult(ivx,iiip)+1
- end if
-74 continue
- isxtup = .false.
- end if
- if (btest(irest(ivx,iip),0)) then
- nrests = nrests+1
- else
- sum = sum+nolev(ivx,iip)
- end if
-9 continue
-c
-c Set beam up-down-ness
-c
- if (ifb.gt.0 .and. ulfbq(ivx,max(1,ifb)).ne.'x') then
- if (ulfbq(ivx,ifb) .eq. 'f') then
-c
-c Get default, then trade "l" and "u"
-c
- ulq(ivx,numnow) = char(225-ichar(
- * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1))))
- else
- ulq(ivx,ifb) = ulfbq(ivx,ifb)
- end if
-c
-c This probably works only because forced beams are done first, so they
-c don't have to be re-sorted within each voice. ????
-c
- else if (nvmx(iv) .eq. 2) then
-c
-c Multi-voice per staff
-c
- if (ivx .le. nv) then
- ulq(ivx,numnow) = 'l'
- else
- ulq(ivx,numnow) = 'u'
- end if
- else
-c
-c Defaults
-c
- ulq(ivx,numnow) =
- * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1))
- end if
- return
- end
- subroutine m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
-c
-c This is called when (a) macro recording is just starting and
-c (b) at the start of a new line, if recording is on
-c
- parameter (maxblks=9600)
- character*128 lineq,lnholdq
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- logical mrecord,mplay,endmac
- character*131072 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- lbuf(1) = lbuf(1)
- if (.not.mrecord) then
-c
-c Starting the macro
-c
- ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount
- il1mac(macnum) = ilbuf-1
- ic1mac(macnum) = iccount
- mrecord = .true.
- end if
- if (iccount .lt. 128) then
- ndxm = index(lineq(iccount+1:128),'M')
- if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M',
- * 128-iccount)
- if (ndxm .gt. 0) then
-c
-c This line ends the macro.
-c
- if (lineq(iccount+ndxm+1:iccount+ndxm+1) .ne. ' ') then
- call errmsg(lineq,iccount+ndxm+1,ibarcnt-ibaroff+nbars+1,
- * 'Improper macro termination!')
- call stop1()
- end if
- ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm
- il2mac(macnum) = ilbuf-1
- mrecord = .false.
- end if
- end if
- return
- end
- subroutine make1bar(ibmrep,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart)
- parameter (nm=24,mv=24576)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*10 figq
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig,bar1syst
- common /comeskz2/ eskz2(nm,200)
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2,ivvfig(2,74)
- common /combeam/ ibmtyp
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comas2/ nasksys,wasksys(800),elasksys(800)
- common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,autofbon
- character*128 litq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * maxdotmv(nm),ndotmv(nm),updot(nm,20),rtdot(nm,20)
- integer cnn(nm),istart(80),istop(80),nxtnow(nm),ifbnow(nm),
- * numbms(nm),mapfb(16)
- real*4 xit(nm),t1xtup(20),tstart(80),squez(80)
- character*1 ulfbq
- character*79 inameq
- character*20 voltxtq
- common /comoct/ noctup
- character*80 headrq,lowerq
- logical cwrferm
- common /comcwrf/ cwrferm(nm)
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- logical lower,cwrest(nm),vxtup,flgndb,btest,upslur,
- * infbmx(nm),lowdot,inxtup(nm),drawbm
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /comstart/ facmtr
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
-c
-c Above are factors for grace note, clef spacing. (fraction of wheadpt)
-c In 1.04, moved to block data subprogram
-c
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig,
- * lnam(nm),inameq(nm)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comtol/ tol
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur,
- * WrotePsslurDefaults
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /comntot/ ntot
- if (ismidi) then
-c
-c Initialize for this bar the accidental counter for the midi file.
-c naccim(icm) = # of accidentals from earlier in the bar
-c
- do 45 iv = 1 , nv
- do 45 kv = 1 , nvmx(iv)
- naccim(midchan(iv,kv)) = 0
-45 continue
- end if
-c
-c Time from start of gulp to end of bar, used with forced beams
-c
- tglp2 = lenb0+ibar*lenb1
- if (lenb0 .gt. 0) tglp2 = tglp2-lenb1
- tglp1 = tglp2-lenbar
-c
-c infbmx will only be true if in xtup that is NOT in explicit forced beam.
-c
- do 1 iv = 1 , nv
- do 1 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- cwrest(ivx) = .false.
- infbmx(ivx) = .false.
- inxtup(ivx) = .false.
- if (ibar .gt. 1) then
- nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1)
- else
- nn(ivx) = nib(ivx,ibar)
- end if
-1 continue
-c
-c initialize list note counter, time(iv), curr. note(iv). The loop to 4
-c ONLY initializes each voice.
-c
- in = 1
- nxtup = 0
- narp = 0
- do 4 iv = 1 , nv
- do 4 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- cwrferm(ivx) = .false.
- cnn(ivx) = 1
- ivxo(in) = ivx
- ipo(in) = cnn(ivx)
- tnote(in) = fnote(nodur,ivx,1,nacc)
- to(in) = 0.
- xit(ivx) = tnote(in)
-c
-c Note that xit(ivx) is to END of note in voice, but it1xtup is start time.
-c
- if (nodur(ivx,ipo(in)) .eq. 0) then
-c
-c First note of xtuplet at start of bar in voice ivx.
-c
- nxtup = nxtup+1
- nxtnow(ivx) = nxtup
- inxtup(ivx) = .true.
- t1xtup(nxtup) = 0.
-c
-c Xtup at start of bar. If no explicit forced beam, start one, set
-c signal infbmx, and save number ifbnow for use at termination.
-c
- if (nfb(ivx) .gt. 0) then
- do 60 ifb = 1 , nfb(ivx)
- if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c No explicit fb here; so exit loop and insert one.
-c
- go to 61
- else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and.
- * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c IS explicit fb here; must NOT insert one
-c
- go to 62
- end if
-60 continue
- end if
-61 continue
-c
-c If here, xtup isn't in explicit fb, so must insert one
-c
- infbmx(ivx) = .true.
- call addfb(nfb,ivx,t1xtup(nxtup)+
- * tglp1,t1fb,t2fb,ulfbq,ifbadd)
- ifbnow(ivx) = ifbadd
- end if
-62 continue
- if (abs(xit(ivx)-lenbar) .lt. tol) xit(ivx) = 1000.
- in = in+1
-4 continue
-c
-c Build the list: This is a manual loop starting at 5
-c
-5 continue
-c
-c Determine which voice comes next from end of notes done so far.
-c tmin is the earliest ending time of notes done so far
-c
- tmin = 1000.
- do 6 iiv = 1 , nv
- do 6 kv = 1 , nvmx(iiv)
- iivx = ivmx(iiv,kv)
- tminn = min(tmin,xit(iivx))
- if(tminn .lt. tmin-tol) then
- tmin = tminn
- ivx = iivx
- end if
-6 continue
- if (abs(tmin-1000.) .lt. tol) go to 7
- ivxo(in) = ivx
- cnn(ivx) = cnn(ivx)+1
- ipo(in) = cnn(ivx)
- to(in) = tmin
-c
-c Check if this voice is done
-c
- tnote(in) = fnote(nodur,ivx,cnn(ivx),nacc)
- if (cnn(ivx) .eq. nn(ivx)) then
- xit(ivx) = 1000.
- else
- xit(ivx) = xit(ivx)+tnote(in)
- end if
-c
-c Flag xtups
-c
- if (nodur(ivx,cnn(ivx)) .eq. 0) then
- if (.not.inxtup(ivx)) then
-c
-c First note of xtup, not at start of bar.
-c
- nxtup = nxtup+1
- nxtnow(ivx) = nxtup
- inxtup(ivx) = .true.
- t1xtup(nxtup) = xit(ivx)-tnote(in)
-c
-c (Note: can't be on last note in voice, so xit(ivx) <> 1000)
-c Put xtuplet in a forced beam if not already in forced beam
-c
- if (nfb(ivx) .gt. 0) then
- do 70 ifb = 1 , nfb(ivx)
- if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c NO explicit bm; put one in
-c
- go to 71
- else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and.
- * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c IS explicit bm. Don't put one
-c
- go to 72
- end if
-70 continue
- end if
-71 continue
-c
-c If here, no explicit bm, so put one in
-c
- infbmx(ivx) = .true.
- call addfb(nfb,ivx,t1xtup(nxtup)+tglp1,
- * t1fb,t2fb,ulfbq,ifbadd)
- ifbnow(ivx) = ifbadd
- end if
-72 continue
- else if (inxtup(ivx)) then
-c
-c This test is sufficient because already know nodur>0
-c
- inxtup(ivx) = .false.
- if (infbmx(ivx)) then
-c
-c Xtup is in auto-forced beam, so end it
-c
- t2fb(ivx,ifbnow(ivx)) =
- * t1xtup(nxtnow(ivx))+nodur(ivx,cnn(ivx))+tglp1
- infbmx(ivx) = .false.
- end if
- end if
- if (btest(irest(ivxo(in),ipo(in)),24) .or.
- * btest(irest(ivxo(in),ipo(in)),30)) then
-c
-c For staff jumped beam, flag the first note (lowest voice) at same time.
-c Later will start new notes group here.
-c
- inj = in
- if (ivxo(in) .gt. 1) then
- do 40 iin = in-1 , 1 , -1
- if (to(iin)+tol .lt. to(in)) go to 41
- if (abs(to(iin)-to(in)) .lt. tol) then
- inj = iin
- go to 40
- end if
-40 continue
- end if
-41 continue
- irest(ivxo(inj),ipo(inj)) = ibset(irest(ivxo(inj),ipo(inj)),29)
- end if
- in = in+1
- go to 5
-7 continue
- ntot = in-1
- do 8 in = 1 , ntot-1
- tno(in) = to(in+1)-to(in)
-8 continue
- tno(ntot) = tnote(ntot)
-c
-c Debug writes
-c
-c write(*,'()')
-c write(*,'(a)')' Greetings from PMXB'
-c write(*,'(16i5)')(ivxo(in),in=1,ntot)
-c write(*,'(16i5)')(ipo(in),in=1,ntot)
-c write(*,'(16f5.1)')(to(in),in=1,ntot)
-c write(*,'(16f5.1)')(tno(in),in=1,ntot)
-c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot)
-c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot)
-c
-c Done w/ list. Loop for parsing into note blocks:
-c
- ib = 1
- istart(1) = 1
- space(1) = 0.
- in = 1
-c
-c A manual loop to set space(ib) and istop(ib)
-c
-9 continue
-
- ivx = ivxo(min(in+1,ntot))
- ip = ipo(min(in+1,ntot))
- isl = islur(ivx,ip)
- if (in.eq.ntot .or. ((ivx.eq.1 .and.
- * (iand(isl,67109216).gt.0 .or. btest(ipl(1,ip),28)
-c * .or. ornq(1,ip).eq.'g')) .or. btest(isl,15) )) then
-c Bits 1-13: stmgx+Tupf._)
-c 14: Down fermata, was F
-c 15: Trill w/o "tr", was U
- * .or. btest(iornq(1,ip),4))) .or. btest(isl,15) )
-c
-c Checking for start of 2nd part of jumped beam
-c
- * .or. btest(irest(ivx,ip),29) ) then
-c
-c Bar end, segno, int. rpt or sig change, clef,end of 1st part of jumped beam;
-c flow out of if-loop and into block-wrapup
-c
-c 10/18/97: Problem with clef alignment. Got isl{15} set on lowest-numbered
-c voice, but it wasn't first in the list at the same time. So check if
-c prior notes in list have same time
-c 5/25/98: This stuff causes trouble with just "c2 Ct c", maybe when clef
-c changes on last note in the list?
-c
- if (btest(isl,15) .and. in.lt.ntot) then
- do 50 iin = in , 1 , -1
- if (tno(iin) .gt. tol) then
- in = iin
- islur(ivx,ip) = ibclr(islur(ivx,ip),15)
- islur(ivxo(in+1),ipo(in+1)) =
- * ibset(islur(ivxo(in+1),ipo(in+1)),15)
- go to 51
- end if
-50 continue
-51 continue
- end if
- if (space(ib) .lt. tol) then
- space(ib) = tno(in)
- squez(ib) = 1.
- end if
- istop(ib) = in
- else if (space(ib) .lt. tol) then
-c
-c space hasn't been set yet, so tentatively set:
-c
- space(ib) = tno(in)
- if (space(ib) .lt. tol) then
- in=in+1
- else
- squez(ib) = getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- end if
- go to 9
- else if (tno(in+1) .lt. tol) then
-c
-c This is not the last note in the group, so
-c
- in = in+1
- go to 9
- else if (abs(tno(in+1)-space(ib)) .lt. tol) then
- xsquez = getsquez(in+1,ntot,space(ib),tnote,to)
- if (abs(xsquez-squez(ib)) .lt. tol) then
-c
-c Keep spacing the same, update tentative stop point
-c
- in = in+1
- istop(ib) = in
- go to 9
- end if
- end if
-c
-c At this point istart and istop are good, so finalize block
-c
- tstart(ib) = to(istart(ib))
- if (istop(ib) .eq. ntot) go to 15
- ib = ib+1
- istart(ib) = istop(ib-1)+1
- in = istart(ib)
-c
-c Set tentative block space and squeeze-factor for upcoming block
-c
- space(ib) = tno(in)
- if (space(ib).gt.tol)
- * squez(ib)= getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- go to 9
-15 continue
- nb = ib
-c
-c Invert the list of places into ipl(0-7), making it easier to analyze a voice
-c
- do 13 in = 1 , ntot
-c
-c ??? This may fix extra \loff's (bit 8 of ipl) in measures with >255 notes.
-c
-c ipl(ivxo(in),ipo(in)) = ior(ipl(ivxo(in),ipo(in)),in)
- ipl2(ivxo(in),ipo(in)) = in
-13 continue
-c
-c Compute elemskips from start of bar to each note in the bar, for beam slopes
-c
- eskzb = 0.
- ib = 1
- do 30 in = 1 , ntot
- if (in .eq. istart(ib)) then
- deskb = squez(ib)*feon(space(ib)/squez(ib))
- else if (tno(in-1) .gt. tol) then
- eskzb = eskzb+deskb
- end if
- eskz(ivxo(in),ipo(in)) = eskzb
- eskz2(ivxo(in),ipo(in)) = eskzb
- if (in .eq. istop(ib)) then
- eskzb = eskzb+deskb
- ib = ib+1
- end if
-30 continue
-c
-c Analyze for beams.
-c
- do 20 iv = 1 , nv
- do 20 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- numbms(ivx) = 0
- mapfb(1) = 0
- mapfb(2) = 0
- mapfb(3) = 0
- mapfb(4) = 0
-c
-c First forced beams.
-c
- if (nfb(ivx) .gt. 0) then
-c
-c tglp2 is time from start of gulp to end of current bar.
-c
- nfbbar = 0
- do 80 ifb = 1 , nfb(ivx)
- if (t1fb(ivx,ifb).gt.tglp2-tol) go to 81
- nfbbar = nfbbar+1
- numbms(ivx) = numbms(ivx)+1
- numnew = numbms(ivx)
-c
-c Times from beginning of bar
-c
- itbb1 = int(t1fb(ivx,ifb)-tglp1+tol)
- itbb2 = int(t2fb(ivx,ifb)-tglp1+tol)
- do 83 ip = 1 , nn(ivx)
- if (int(to(ipl2(ivx,ip))+tol) .eq. itbb1) then
- nip1fb = ip
- do 84 ip1 = ip , nn(ivx)
- inip1 = ipl2(ivx,ip1)
- if (abs(to(inip1)+tnote(inip1)-itbb2) .lt. tol) then
- nip2fb = ip1
- itbb3 = itbb2-2
- go to 85
- end if
-84 continue
- end if
-83 continue
- print*
- print*,'Timing problem w/ forced beams'
- write(15,'(/a)')'Timing problem w/ forced beams'
-85 continue
- call logbeam(numnew,nip1fb,nip2fb)
-c
-c Set up mapfb for forced beam just logged:
-c
- ib1 = itbb1/2
- ib2 = itbb3/2
- ibrep = lenbar/ibmrep/2
- do 86 irep = 1 , ibmrep
- ib1now = max(0,ib1-(irep-1)*ibrep)
- ib2now = min(irep*ibrep-1,ib2-(irep-1)*ibrep)
- mapnow = 0
- do 87 ib = ib1now , ib2now
- mapnow = ibset(mapnow,ib)
-87 continue
- mapfb(irep) = ior(mapfb(irep),mapnow)
-86 continue
-c
-c Since we are cycling thru forced beams, for those that start with a rest and
-c have height & slope adjustments, move adjustments to next note.
-c 060924: Copy to ALL later notes in fb, in case there's more than 1 rest at
-c start of beam
-c
- if (btest(irest(ivx,nip1fb),0)) then
- do 88 kp = nip1fb+1 , nip2fb
- call setbits(ipl(ivx,kp),6,11,
- * igetbits(ipl(ivx,nip1fb),6,11))
- call setbits(ipl(ivx,kp),6,17,
- * igetbits(ipl(ivx,nip1fb),6,17))
- call setbits(islur(ivx,kp),2,27,
- * igetbits(islur(ivx,nip1fb),2,27))
-88 continue
- end if
-80 continue
-81 continue
-c
-c Slide down, reduce nfb(ivx). This lets us count up from 1 for each new bar.
-c Remember, makeabar is called 1/bar, and it calls findbeam once per voice.
-c
- if (nfbbar .gt. 0) then
- nfb(ivx) = nfb(ivx)-nfbbar
- do 82 ifb = 1 , nfb(ivx)
- t1fb(ivx,ifb) = t1fb(ivx,ifb+nfbbar)
- t2fb(ivx,ifb) = t2fb(ivx,ifb+nfbbar)
- ulfbq(ivx,ifb) = ulfbq(ivx,ifb+nfbbar)
-82 continue
- end if
- end if
- ifb = 0
-c
-c Done with forced beam masks for this bar and voice. Now get normal beams.
-c
- call findbeam(ibmrep,numbms,mapfb)
-20 continue
- return
- end
- subroutine make2bar(ninow,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart,clefq)
- parameter (nm=24,mv=24576)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*10 figq
- character*1 ulq,sepsymq,sq,chax
- logical beamon,firstgulp,figbass,figchk,isfig,bar1syst,isbjmp,
- * isbj2
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2,multbj1
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2,ivvfig(2,74)
- common /combeam/ ibmtyp
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comas2/ nasksys,wasksys(800),elasksys(800)
- common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,issig,rpndot,autofbon
- character*128 litq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * maxdotmv(nm),ndotmv(nm),updot(nm,20),rtdot(nm,20)
- integer istart(80),istop(80),iaskb(nm),numbms(nm),
- * nornb(nm),ihornb(nm,24),lcwr(nm),ibmcnt1(nm),ifig(2)
- character*1 ulfbq,udqq,clefq(nm),slurudq,udq
- character*8 noteq
- character*79 cwrq(nm),notexq,inameq
- character*20 voltxtq
- common /comoct/ noctup
- character*80 soutq,headrq,lowerq
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- logical bspend,lower,cwrest(nm),vxtup,
- * isgrace,isclef,nofirst,iscln,isdot,isflag,
- * isacc,isfirst,flgndb,btest,stemup,upslur,
- * isgaft,isarp,isrshft,isaccs,iscacc,
- * lowdot,flipend,iscwr,isdotted,beamon1(nm)
- real*4 ptgr(37),ptclef(nm),ptsndg(nm),eskndg(nm),tstart(80),
- * squez(80)
- logical cwrferm,drawbm
- common /comcwrf/ cwrferm(nm)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /comstart/ facmtr
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
-c
-c Factors for grace note, clef spacing. (fraction of wheadpt)
-c In 1.04, moved to block data subprogram
-c
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig,
- * lnam(nm),inameq(nm)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comtol/ tol
- common /comignorenats/ mbrhgt,newmbrhgt,ignorenats
- logical ignorenats,newmbrhgt
- integer*2 mmidi,iinsiv
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur
- * ,WrotePsslurDefaults
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- common /comevent/ miditime,lasttime
- logical kbdrests
- common /comkbdrests/ levbotr(8),levtopr(8),kbdrests
- logical secondgrace
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /commidisig/ midisig
-c 130316
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
- common /comclefrests/ centrests
- logical centrests
- common /xjbeambrests/ nbrests
- common /comc8flag/ c8flag(nm)
- logical c8flag
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- character*4 ivxq
- logical rename
- common /comshort/ shortfrac,codafrac,ishort,mbrsum,nmbr,nocodabn,
- * poefa
- real*4 poefa(125)
- logical nocodabn
- nbrests = 0
-c
-c Set up main ib loop within which a block (notes group) is written
-c
- do 25 iv = 1 , nv
- do 25 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- ibmcnt(ivx) = 1
- ibmcnt1(ivx) = 1
- beamon(ivx) = .false.
- beamon1(ivx) = .false.
- nornb(ivx) = 0
- iaskb(ivx) = 1
- vxtup(ivx) = .false.
- drawbm(ivx) = .true.
-25 continue
- naskb = 0
- ifig(1) = 1
- ifig(2) = 1
- ixtup = 0
- bspend = .false.
- iscwr = .false.
- rpndot = .false.
- do 16 ib = 1 , nb
-c
-c Check for segno
-c
- if (btest(iornq(1,ipo(istart(ib))),4) .and.
- * ivxo(istart(ib)).eq.1) then
- if (noffseg.le.-10) then
- write(noteq(1:5),'(1H{,i3,1H})')noffseg
- lnoten = 5
- else if (noffseg.lt.0 .or. noffseg.ge.10) then
- write(noteq(1:4),'(1H{,i2,1H})')noffseg
- lnoten = 4
- else
- write(noteq(1:1),'(i1)')noffseg
- lnoten = 1
- end if
- notexq = sq//'znotes'//sq//'segnoo'//noteq(1:lnoten)//'9'
- lnote = 15+lnoten
- do 130 iv = 2 , nv
- if (lnote .gt. 60) then
- if (islast) write(11,'(a)')notexq(1:lnote)//'%'
- notexq = sepsymq(iv-1)//sq//'segnoo'
- * //noteq(1:lnoten)//'9'
- lnote = lnoten+9
- else
- notexq = notexq(1:lnote)//sepsymq(iv-1)//sq//'segnoo'
- * //noteq(1:lnoten)//'9'
- lnote = lnote+lnoten+9
- end if
-130 continue
- if (islast) write(11,'(a)')notexq(1:lnote)//sq//'en'
- lnote = 0
- end if
-c
-c Check for new clefs
-c
- isclef = .false.
- if (btest(islur(ivxo(istart(ib)),ipo(istart(ib))),15))
- * then
-c
-c In preceding line, fl32 gave wrong result for ... .gt.0 !!!
-c
- do 140 in = istart(ib) , istop(ib)
- if (btest(islur(ivxo(in),ipo(in)),11)) then
- call wsclef(ivxo(in),ninow,
- * iand(ishft(islur(ivxo(in),ipo(in)),-12),7))
-c
-c If clefq = '8', must add eg \settrebleclefsymbol3\treblelowoct%
-c
-c if (clefq(ivxo(in)) .eq. '8') then
- if (btest(ipl(ivxo(in),ipo(in)),2)) then
-c
-c Find instrument number for voice ivso(in)
-c
- iv1 = 1
- do 1111 iinst = 1 , ninow
- if (ivxo(in) .lt. iv1+nspern(iinst)) go to 2222
- iv1 = iv1+nspern(iinst)
-1111 continue
- print*
- print*,'Should not be here in make2bar!'
- call stop1()
-2222 continue
- if (iinst .le. 9) then
- write(11,'(a20,i1,a)')sq//'settrebleclefsymbol',
- * iinst,sq//'treblelowoct%'
- else
- write(11,'(a20,i2,a)')sq//'settrebleclefsymbol',
- * iinst,sq//'treblelowoct%'
- end if
- c8flag(ivxo(in)) = .true.
- end if
- end if
-140 continue
- if (islast) write(11,'(a)')sq//'pmxnewclefs'
- isclef = .true.
- end if
-c
-c Start a notes group. We're just gonna define every one using pnotes{n},
-c where \def\pnotes#1{\vnotes#1\elemskip}
-c
- soutq = sq//'pnotes{'
- eonsqz = squez(ib)*feon(space(ib)/squez(ib))
- if (eonsqz .gt. 9.995) then
- write(soutq(9:12),'(f4.1)')eonsqz
- else if (eonsqz .gt. 0.995) then
- write(soutq(9:12),'(f4.2)')eonsqz
- else if (eonsqz .gt. 0.095) then
- soutq = soutq(1:8)//'0.'
- write(soutq(11:12),'(i2)')nint(100*eonsqz)
- else
- soutq = soutq(1:8)//'0.0'
- write(soutq(12:12),'(i1)')nint(100*eonsqz)
- end if
- soutq = soutq(1:12)//'}'
- lsout = 13
-c
-c Check whole block, flag accidentals etc that are too close, one per *time*.
-c Note about bar starts and after rpt's/boublebars: There is an afterruleskip
-c (fbar*wheadpt) following, but rpts seem to occupy some of that gap, so
-c (dotsfac*wheadpt) is presumed to be filled up.
-c
- in = istart(ib)-1
- itrpt = -1
- itsig = -1
-c
-c Begin big manual loop over notes in this block; ends at 112
-c
-111 in = in+1
- if (in .gt. istop(ib)) go to 112
- ip = ipo(in)
- ivx = ivxo(in)
- if (ivx .le. nv) then
- iv = ivx
- else
- do 128 iv = 1 , nv
- if (nvmx(iv) .eq. 2 .and. ivmx(iv,2).eq. ivx) go to 129
-128 continue
- print*,'Trouble finding iv!, ivx,nvmx,ivmx:',ivx,nvmx(1),nvmx(2)
- print*,ivmx(1,1),ivmx(1,2),ivmx(2,1),ivmx(2,2)
- stop
- end if
-129 continue
-c
-c Call precrd here so we know how much space to add for accid's in chords
-c After calling precrd, icashft>0 means there is a shifted chordal accid (incl.
-c main note.
-c
-c To call precrd, need up-downness, so must track if in beam.
-c
-c Deal w/ staff-jumping beams later
-c if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx)
-c * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or.
-c * btest(nacc(ivx,ip),21)) then
-c if (.not.btest(irest(ivx,ip),24)) then
- if ((numbms(ivx).gt.0 .and. ibmcnt1(ivx).le.numbms(ivx)
- * .and. ibm1(ivx,ibmcnt1(ivx)) .eq. ip)) then
- beamon1(ivx)=.true.
- end if
- icashft = 0
- if (btest(ipl(ivx,ip),10)) then
-c
-c There is a chord on this note. Need up-down-ness in precrd to auto shift for 2nds.
-c
- if (beamon1(ivx)) then
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt1(ivx)),
- * .false.,icashft)
- else
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip),
- * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv),
- * .false.,icashft)
- end if
- end if
-c
-c Turn beam off?
-c
- if (beamon1(ivx) .and. ibm2(ivx,ibmcnt1(ivx)).eq.ip) then
- beamon1(ivx) = .false.
- ibmcnt1(ivx) = ibmcnt1(ivx)+1
- end if
-c
-c Remember, rpts & internal sigs can only come at start of (internal) block
-c
- isacc = iand(nacc(ivx,ip),3).gt.0
- * .and. .not.btest(nacc(ivx,ip),17)
- * .and. .not.btest(ipl(ivx,ip),10)
-c
-c i.e., do not set for chord. Now check for "(" as ornament on main note,
-c
-c!!! Need to do this for chord notes too. Maybe in chkarp?
-c
- isaccs = isacc .or. btest(iornq(ivx,ip),0)
-c
-c 5/15/02 Add check for ) ornament of prior note.
-c 5/16 Nope...fails when grace intervenes.
-c if (ip .gt. 1) then
-c isaccs = isaccs .or. btest(iornq(ivx,ip-1),13)
-c end if
- isarp = btest(iornq(ivx,ip),27)
- iscacc = .false.
- if (btest(ipl(ivx,ip),10)) then
-c
-c There is a chord here; check for arpeggios and accidentals. Note accid shifts are
-c not of concern here, only whether there's an accid, whick causes iscacc=.true.
-c
- iscacc = igetbits(nacc(ivx,ip),3,0).gt.0 .and.
- * .not.btest(nacc(ivx,ip),17)
- call chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp)
- end if
-c
-c When we get motivated, will do spacing for arpeggios here.
-c
- if (ivx.eq.1 .and. iand(islur(ivx,ip),96).gt.0)
- * itrpt = nint(to(in))
- issig = btest(ipl(ivx,ip),28)
- if (ivx.eq.1 .and. issig) itsig = nint(to(in))
- isgrace = btest(islur(ivx,ip),4) .and.
- * .not.btest(ipl(ivx,ip),29) .and. .not.btest(ipl(ivx,ip),31)
- isgaft = .false.
- if (ip .gt. 1) then
- xnd = tnote(ipl2(ivx,ip-1))
- isgaft = btest(ipl(ivx,ip-1),29) .or. btest(ipl(ivx,ip-1),31)
- isgrace = isgrace .or. isgaft
- end if
- iscln = isclef .and. btest(islur(ivx,ip),11)
-c
-c Is prev. note non-beamed, up-stemmed, & flagged? Recall if ip>1, have nd
-c
- isflag = ip.gt.1 .and. xnd.gt.tol .and. xnd.lt.16.-tol
- if (isflag)
- * isflag = .not.btest(irest(ivx,ip-1),0)
- * .and. udqq(nolev(ivx,ip-1),
- * ncmid(iv,ip-1),islur(ivx,ip-1),nvmx(iv),ivx,nv).eq.'u'
- if (isflag) then
- do 116 ibmchk = 1 , numbms(ivx)
- if (ip-1 .lt. ibm1(ivx,ibmchk)) then
- go to 117
-c
-c Add check for non-beamed xtuplets. May be problem with stem direction.
-c
- else if (ip-1.le.ibm2(ivx,ibmchk) .and.
- * .not.btest(islur(ivx,ibm1(ivx,ibmchk)),18)) then
- isflag = .false.
- go to 117
- end if
-116 continue
- end if
-117 continue
-c
-c If isflag, then won't need to check for dot on prev. note.
-c
-c 5/16/02 ??? Try using this for ) ornament.
-c
- isflag = isflag .or. btest(iornq(ivx,ip-1),13)
- isdot = ip.gt.1
- if (isdot) isdot = isdotted(nodur,ivx,ip-1)
- isrshft = ip .gt. 1
- if (isrshft) isrshft = btest(irest(ivx,ip-1),20)
- if (.not.(isaccs.or.isgrace.or.iscln.or.isflag.or.isrshft.or.
- * isdot.or.btest(iornq(ivx,ip),26).or.
- * btest(irest(ivx,ip),21).or.isarp.or.
- * btest(irest(ivx,ip),27).or.iscacc)) go to 111
-c
-c Here is an accid,grace,clef,flag,rtshft,dot,udsp,arpeg,left-shift.
-c Compute pts, the total occupied space including prior notehead.
-c
-c 130324
-c wheadpt1 = wheadpt*fullsize(iv)
- wheadpt1 = wheadpt*fullsize(instno(iv))
- pts = wheadpt1
-c
-c Set up for possible cautionary accidental here
-c
- if (isaccs .or. iscacc) then
- if (.not.btest(iornq(ivx,ip),31)) then
- taccfac = accfac
- else
- taccfac = 1.4*accfac ! cautionary accidental
- end if
- end if
- if (isgrace) then
- secondgrace = .false.
- do 122 ig = 1 , ngrace
- if (.not. isgaft) then
- if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 123
- else if (ip .gt. 1) then
- if (ipg(ig).eq.ip-1 .and. ivg(ig).eq.ivx) go to 123
- end if
-122 continue
- print*,'Problem finding grace index in makeabar'
- stop
-123 continue
-c
-c wgr = distance to backspace (in headwidths), less main acc.
-c ptgr = same in pts,+ main acc. Not used for after-grace. Distance to backspace.
-c spgr = total space needed (w/o main acc).
-c Also, spgr is same for b4 or after, but xb4fac-space will be in diff. place.
-c
- if (nng(ig) .eq. 1) then
- wgr = grafac
- if (multg(ig) .eq. 0) wgr = wgr-.4
- else
- wgr = nng(ig)*emgfac
- do 126 ing = 2 , nng(ig)
- if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac
-126 continue
- end if
- if (graspace(ig) .gt. 0.) then
-c
-c User-defined space before grace
-c
- wgr = wgr+graspace(ig)
- end if
- ptgr(ig) = wgr*wheadpt1
- spgr = ptgr(ig)+xb4fac*wheadpt1
-c
-c!!! May need to mod for chord accid's
-c
- if (isaccs .or. iscacc) ptgr(ig) = ptgr(ig) + taccfac*wheadpt1
- if (naccg(ngstrt(ig)) .gt. 0) spgr = spgr+wheadpt1*agc1fac
- pts = pts+spgr
-c
-c Special check for after-grace on ip-1 and normal on ip. Must go back thru
-c loop again for the normal grace.
-c
- if (isgaft .and. ig.lt.ngrace .and. .not.secondgrace) then
- if (ipg(ig+1).eq.ip) then
- secondgrace = .true.
- ig = ig+1
- go to 123
- end if
- end if
- end if
- if (iscln) then
- pts = pts+clefac*wheadpt1
-c
-c How far to backspace when printing the clef
-c
- ptclef(ivx) = 0.
-c
-c!!! May need to mod for chord accid's
-c
- if (isaccs .or. iscacc)
- * ptclef(ivx) = ptclef(ivx)+taccfac*wheadpt1
- if (isgrace) ptclef(ivx) = ptclef(ivx)+spgr
- end if
- if (isrshft) then
- pts = pts+rtshfac*wheadpt1
- else if (isflag) then
- pts = pts+flagfac*wheadpt1
- else if (isdot) then
- pts = pts+dotfac*wheadpt1
- end if
- if (abs(to(in)-itrpt) .lt. tol) then
-c
-c Repeat, need a little extra space
-c
- pts = pts+dotsfac*wheadpt1
- end if
- if (isarp) then
- pts = pts+arpfac*wheadpt1
- end if
-c
-c Add in padding space
-c
- pts = pts+xspfac*wheadpt1
-c
-c Now done with all items needing space except accidentals,
-c accidental shifts, and left-notehead-shifts, and will later
-c subtract a notehead if at start of bar.
-c
-c Get available space in elemskips (esk)
-c
- isfirst = ip.eq.1 .or. abs(to(in)-itrpt).lt.tol .or.
- * abs(to(in)-itsig).lt.tol
- if (isfirst) then
-c
-c At start of bar or after repeat sign or new signature
-c
- if (abs(to(in)-itsig).lt.tol) then
- esk = 0.
- else
- esk = fbar
- end if
- else
-c
-c Not 1st note of bar
-c
- esk = eskz(ivx,ip)-eskz(ivx,ip-1)
- end if
- if (isgrace) then
-c
-c Since graces can be very long, cannot assume no interference if prior
-c note uses >1 noteskip. So must get elsk's back to prior note, whether or
-c not it used only one noteskip.
-c <<But if it was xtup. don't need to call eskb4.>>????
-c
-c 10/8/05 Kluge to not zero out esk if in xtup
-c
- esksav = esk
- if ((ip.le.2 .or. nodur(ivx,max(1,ip-2)).gt.0) .and.
-c * to(in).ne.itsig)
- * abs(to(in)-itsig).gt.tol)
- * call eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk)
- if (abs(esk) .lt. tol) esk = esksav
- end if
-c
-c Done getting available elemskips. Remove headwidth if first. Must do here
-c rather than earlier since check uses isfirst
-c
- if (isfirst) pts = pts-wheadpt1
-c
-c Deal with accidental shifts and left-notehead shifts
-c
- if (btest(ipl(ivx,ip),10)) then
-c
-c In a chord
-c
- ptsl = 0.
- if (btest(irest(ivx,ip),27)) ptsl = wheadpt1
- ptsadd = max(ptsl,icashft*.05*wheadpt1)
-c
-c Note: may have icashft=-20000 (if shftmin=-1000 in crdacc) but that's OK
-c
- else
-c
-c Not in a chord
-c
- ihshft = 0
- if (isaccs) then
- ihshft = igetbits(nacc(ivx,ip),7,10)
-c if (ihshft .ne. 0) ihshft = max(0,64-ihshft)
- if (ihshft .ne. 0) ihshft = max(0,107-ihshft)
- end if
-c
-c Check for left-shifted main note
-c
- if (btest(ipl(ivx,ip),8)) ihshft = max(20,ihshft)
- ptsadd = ihshft*.05*wheadpt1
- end if
- pts = pts+ptsadd
- if (isgrace) ptgr(ig) = ptgr(ig)+ptsadd
- if (iscln) ptclef(ivx) = ptclef(ivx)+ptsadd
-c
-c Left-shifted, non-chord note before?
-c
- if (ip .gt. 1) then
- if (.not.btest(ipl(ivx,ip-1),10) .and.
- * btest(irest(ivx,ip-1),27)) pts = pts-wheadpt1
- end if
-c
-c Try big accidentals first
-c
- ptbneed = pts
- if (isaccs .or. iscacc) then
- ptbneed = ptbneed+wheadpt1*bacfac
- end if
- if (poefa(iline)*poenom*esk .gt. ptbneed) then
-c
-c Set flag for big accidental
-c
- if (isacc) nacc(ivx,ip) = ibset(nacc(ivx,ip),3)
- go to 99
- end if
-c
-c Cannot use big, so try small
-c
- ptsneed = pts
- if (isaccs .or. iscacc) then
- ptsneed = ptsneed+taccfac*wheadpt1
- end if
- if (poefa(iline)*poenom*esk .lt. ptsneed) then
- call addask(to(in),ptsneed,poefa(iline)*esk,
- * fixednew,scaldold,0.,poefa(iline),.false.)
- end if
-99 continue
- if (btest(iornq(ivx,ip),26)) then
-c
-c User-defined space. Warning, "zero" may change value in addask!
-c
- zero = 0.
- call addask(to(in),ptsneed,zero,
- * fixednew,scaldold,tglp1,1.,.true.)
- end if
-c
-c End of big manual loop over "in" for accidental checking
-c
- go to 111
-112 continue
-c
-c End of ask analysis for this block.
-c
-c Adjust eskz if there are added spaces. Corrects length of xtup brackets.
-c
- if (naskb.gt.0) call adjusteskz(ib,istart,poenom)
-c
-c Check for internal repeat or sig change.
-c
- if (ib.gt.1 .and. ivxo(istart(ib)).eq.1) then
- iirpt = iand(islur(1,ipo(istart(ib))),67109216)
- if (iirpt .gt. 0) then
-c
-c Internal repeat
-c
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%'
- if (iirpt .eq. 96) then
- if (islast) write(11,'(a)')sq//'leftrightrepeat'
- fixednew = fixednew+lrrptfac*wheadpt
- else if (btest(iirpt,5)) then
- if (islast) write(11,'(a)')sq//'leftrepeat'
- fixednew = fixednew+rptfac*wheadpt
- else if (btest(iirpt,6)) then
- if (islast) write(11,'(a)')sq//'rightrepeat'
- fixednew = fixednew+rptfac*wheadpt
- else if (btest(iirpt,8)) then
- if (islast) write(11,'(a)')sq//'doublebar'
- else
- print*,'Unexpected mid-bar repeat command R*'
- call stop1()
- end if
- scaldold = scaldold-fbar
- end if
- if (btest(ipl(1,ipo(istart(ib))),28)) then
-c
-c Internal signature change.
-c
- notexq = sq//'generalsignature{'
- lnote = 18
- if (isig .lt. 0) then
- notexq = notexq(1:lnote)//'-'
- lnote = lnote+1
- end if
- if (islast) write(11,'(a)')notexq(1:lnote)
- * //chax(48+abs(isig))//'}%'
- if (islast .and. ignorenats)
- * write(11,'(a)')sq//'ignorenats%'
- if (islast) write(11,'(a)')sq//'zchangecontext'//sq
- * //'addspace{-.5'//sq//'afterruleskip}%'
- lnote = 0
- end if
- end if
- flgndb = .false.
-c
-c Done with start-of-block stuff. Begin main loop over voices.
-c
- do 11 iv = 1 , nv
- do 11 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- icm = midchan(iv,kv)
-c
-c A rather klugey way to set flag for figure in this voice
-c Must always check figbass before figchk.
-c
- if (figbass) then
- ivf = 0
- if (ivx .eq. 1) then
- ivf = 1
- else if (ivx .eq. ivxfig2) then
- ivf = 2
- end if
- if (ivf.gt.0) figchk(ivf) = nfigs(ivf).gt.0
- end if
- if (ivx .gt. 1) then
- if (ivx .le. nv) then
- call addstr(sepsymq(iv-1),1,soutq,lsout)
- else
- call addstr(sq//'nextvoice',10,soutq,lsout)
- end if
- end if
- if (ihdht.gt.0 .and. ivx.eq.nv) then
-c
-c Write header. First adjust height if needed to miss barno.
-c
- if (bar1syst .and. iline.ne.1) then
- ihdht = 15+irzbnd+isnx
- end if
-c
-c Add user-defined vertical shift
-c
- ihdht = ihdht+ihdvrt
- lchead = lenstr(headrq,80)
- notexq = sq//'zcharnote{'
- write(notexq(12:13),'(i2)')ihdht
- notexq = notexq(1:13)//'}{'//sq//'bigfont'//sq//'kern-30pt '
- call addstr(notexq,34,soutq,lsout)
- call addstr(headrq(1:lchead)//'}',1+lchead,soutq,lsout)
- ihdht = 0
- end if
- if (lower .and. ivx.eq.nv) then
- lclow = lenstr(lowerq,80)
- call addstr(sq//'zcharnote{-6}{'//
- * sq//'tempo'//sq//'kern-10pt '//
- * lowerq(1:lclow)//'}',33+lclow,soutq,lsout)
- lower=.false.
- end if
- tnow = tstart(ib)
- nofirst = .true.
-c
-c Done setting up voice ivx for start of block ib. Loop over notes in voice.
-c
- do 10 jn = istart(ib), istop(ib)
- if (ivxo(jn) .ne. ivx) go to 10
- ip = ipo(jn)
-c
-c May have problem with not initializing islhgt, so do it here
-c
- islhgt = 0
-c
- if (nofirst) then
- noctup = 0
- if (ncmid(iv,ip) .eq. 23) noctup = -2
- nofirst = .false.
- end if
-c
-c Check for internal floating figure (before last note of group).
-c
-12 if (figbass) then
- if (ivx.eq.1 .or. ivx.eq.ivxfig2) then
- ivf = 1
- if (ivx .gt. 1) ivf = 2
- if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.tnow-tol)
- * then
-c
-c Bypassed figure location. Backup, place fig, return.
-c
- offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib)
- call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq,
- * lsout)
- go to 12
- end if
- end if
- end if
-c
-c Put in \sk if needed
-c
- if (to(jn) .gt. tnow+tol) then
- call addstr(sq//'sk',3,soutq,lsout)
- tnow = tnow+space(ib)
- go to 12
- end if
-c
-c Check for user-defined shifts
-c
- if (btest(irest(ivx,ip),15).or.btest(irest(ivx,ip),16))
- * call putshft(ivx,.true.,soutq,lsout)
-21 if (iaskb(ivx).le.naskb .and.
- * tnow.gt.task(iaskb(ivx))-tol) then
- if (task(iaskb(ivx)) .gt. tstart(ib)-tol) then
-c
-c Insert placeholder for accidental skip
-c
- call addstr(sq//'ask ',9,soutq,lsout)
- nasksys = nasksys+1
- wasksys(nasksys) = wask(iaskb(ivx))
- if (wask(iaskb(ivx)) .gt. 0.) then
- elasksys(nasksys) = elask(iaskb(ivx))
- else
-c
-c This is a signal to permit negative ask's. Should really have elask>=0.
-c
- elasksys(nasksys) = -elask(iaskb(ivx))
- end if
- end if
-c
-c May have skipped some task's in earlier blocks (due to void voice)
-c
- iaskb(ivx) = iaskb(ivx)+1
- go to 21
- end if
- if (figbass) then
- if (ivx.eq.1 .or. ivx.eq.ivxfig2) then
- ivf = 1
- if (ivx .gt. 1) ivf = 2
- if (figchk(ivf) .and.
- * abs(itfig(ivf,ifig(ivf))-tnow).lt.tol) then
-c
-c Figure on a note. NB: later special check for late figs.
-c
- call putfig(ivf,ifig(ivf),0.,figchk(ivf),soutq,lsout)
- end if
- end if
- end if
-c
-c Check for new clef here.
-c
- if (isclef .and. btest(islur(ivx,ip),11)) then
- if (ptclef(iv) .gt. 0.) then
- notexq = sq//'off{-'
- if (ptclef(iv) .lt. 9.95) then
- write(notexq(7:9),'(f3.1)')ptclef(iv)
- lnote = 9
- else
- write(notexq(7:10),'(f4.1)')ptclef(iv)
- lnote = 10
- end if
- notexq = notexq(1:lnote)//'pt}'
- lnote = lnote+3
- call addstr(notexq,lnote,soutq,lsout)
- end if
- call clefsym(islur(iv,ip),notexq,lnote,nclef)
-c
-c 151220 If clef is treblelowoct, change '0' in pos'n 9 to '8'
-c
- if (btest(ipl(ivx,ip),2)) notexq =
- * notexq(1:8)//'8'//notexq(10:10)
- call addstr(notexq,lnote,soutq,lsout)
- if (ptclef(iv) .gt. 0.) then
- notexq = sq//'off{'
- if (ptclef(iv) .lt. 9.95) then
- write(notexq(6:8),'(f3.1)')ptclef(iv)
- lnote = 8
- else
- write(notexq(6:9),'(f4.1)')ptclef(iv)
- lnote = 9
- end if
- notexq = notexq(1:lnote)//'pt}'
- lnote = lnote+3
- call addstr(notexq,lnote,soutq,lsout)
- end if
- end if
-c
-c Checking for literal TeX string BEFORE starting beams!!
-c
- if (btest(islur(ivx,ip),16)) then
- do 124 il = 1 , nlit
- if (iplit(il).eq.ip .and. ivlit(il).eq.ivx) go to 125
-124 continue
- print*,'Problem finding index for literal string'
- call stop1()
-125 continue
-c
-c Write a type 1 tex string.
-c
- if (lenlit(il) .lt. 71) then
-c
-c Add normally
-c
- call addstr(litq(il),lenlit(il),soutq,lsout)
- else
-c
-c Longer than 71. Write souq, Write string, start new soutq.
-c
- if (islast) write(11,'(a)')soutq(1:lsout)//'%'
- if (islast) write(11,'(a)')litq(il)(1:lenlit(il))//'%'
- lsout = 0
- end if
- end if
-c
-c Arpeggio on a main (non-chordal) note?
-c
- if (btest(iornq(ivx,ip),27)) then
-c call putarp(tnow,iv,ip,nolev(ivx,ip),ncmid(iv,ip),
- call putarp(tnow,ivx,ip,nolev(ivx,ip),ncmid(iv,ip),
- * soutq,lsout)
- end if
-c
-c See if a beam starts here
-c
- if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx)
- * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or.
- * btest(nacc(ivx,ip),21)) then
- if (.not.btest(irest(ivx,ip),24)) then
-c
-c Not a jump start
-c
- if (kbdrests .and. btest(irest(ivx,ip),0) .and.
- * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and.
- * nolev(ivx,ip).le.50)
- * call chkkbdrests(ip,iv,ivx,nn,islur,irest,nolev,
- * ivmx,nib,nv,ibar,tnow,tol,nodur,2,levtopr,levbotr,
- * mult,ipl)
- call beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib)
-c
-c Shift beam start if notehead was shifted
-c
- if (btest(ipl(ivx,ip),8)) then
- call addstr(sq//'loff{',6,soutq,lsout)
- else if (btest(ipl(ivx,ip),9)) then
- call addstr(sq//'roff{',6,soutq,lsout)
- end if
- if (lnote .gt. 0) call addstr(notexq,lnote,soutq,lsout)
- if (btest(ipl(ivx,ip),8) .or.
- * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout)
- else
-c
-c Jump start. Set marker for second part of a jump beam. Note ivbj2 was set
-c to 0 at end of first part of jump beam
-c
- ivbj2 = ivx
-c
-c Check for xtup since we bypassed beamstrt wherein vxtup is normally set
-c
- if (btest(irest(ivx,ip),28) .and. ixrest(ivx).ne.2)
- * vxtup(ivx) = .true.
-c
-c Since beamstrt is not called, and drawbm is normally set there, need to set
-c it here. This could cause problems if someone tries a staff-jumping,
-c unbarred beam, which I'll deal with when it comes up.
-c
- drawbm(ivx) = .true.
- end if
- if (ixrest(ivx) .eq. 0) then
- beamon(ivx) = .true.
- bspend = .true.
- if (.not.btest(irest(ivx,ip),24))bspend = .true.
- end if
- end if
-c
-c Setup for chords and possible slurs in chords
-c
- if (btest(ipl(ivx,ip),10)) then
-c
-c There is a chord on this note. Just rerun precrd. Klunky, but saves
-c me from tracking down errors instroduced when I moved 1st call
-c forward for accidental spacing analysis.
-c
- if (beamon(ivx)) then
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt(ivx)),
- * .true.,icashft)
- else
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip),
- * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv),
- * .true.,icashft)
- end if
- end if
-c
-c Is there slur or grace activity?
-c
- isgrace = btest(islur(ivx,ip),4)
- if (ip .gt. 1) isgrace = isgrace.or.btest(ipl(ivx,ip-1),31)
-c
-c isgrace if not 1st note in bar and previous note has Way-after grace.
-c
- if (btest(islur(ivx,ip),0) .or. isgrace) then
- if (btest(islur(ivx,ip),0)) then
- if (fontslur) then
-c
-c Call routine for non-postscript slurs
-c
- call doslur(nolev(ivx,ip),isdat1,isdat2,isdat3,nsdat,
- * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout,
- * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip),
- * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)),
- * nacc(ivx,ip))
- else
-c
-c Postscript slurs
-c
- call dopsslur(nolev(ivx,ip),isdat1,isdat2,isdat3,
- * isdat4,nsdat,
- * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout,
- * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip),
- * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)),
- * nacc(ivx,ip))
- end if
- end if
- if (isgrace) then
-c
-c Grace note.
-c
- iphold = ip
- isgrace = .false.
- if (ip .gt. 1) isgrace = btest(ipl(ivx,ip-1),31)
- if (isgrace) iphold = iphold-1
- isgrace = isgrace .or. (.not.btest(ipl(ivx,ip),31)
- * .and..not.btest(ipl(ivx,ip),29))
-c
-c Place grace now if (a) Way-after from prev note and ip>1 or (b) Pre-grace
-c on current note. Do A-grace on current note, and W-grace at barend, later.
-c
- if (isgrace) then
- call dograce(ivx,iphold,ptgr,soutq,lsout,ncmid(iv,ip),
- * nacc(ivx,ip),ig,ipl(ivx,iphold),.false.,
- * beamon(ivx),nolev(ivx,ip),ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),nv,ibmcnt(ivx),
-c 130324
-c * tnote(ipl2(ivx,ip)),ulq)
- * tnote(ipl2(ivx,ip)),ulq,instno(iv))
- if (slurg(ig)) then
-c
-c Terminate slur started in dograce. Get direction of main note stem
-c
- if (.not.beamon(ivx)) then
-c
-c Separate note. Get stem direction.
-c
- stemup = udqq(nolev(ivx,ip),ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),ivx,nv) .eq. 'u'
- else
-c
-c In a beam
-c
- stemup = ulq(ivx,ibmcnt(ivx)) .eq. 'u'
- end if
-c
-c Stop the shift if whole note
-c
- stemup = stemup .or.
- * tnote(ipl2(ivx,ip)).gt.63
- call endslur(stemup,.not.upg(ig),nolev(ivx,ip),0,
- * ndxslur,0,ncmid(iv,ip),soutq,lsout,fontslur)
- end if
- end if
- end if
- if (btest(iornq(ivx,ip),24)) then
-c
-c Start slur on main note for After- or Way-after-grace.
-c
-c???? ndxslur = log2(33554431-listslur)
- ndxslur = log2(16777215-listslur)
-c
-c Get note name
-c
- call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
-c
-c Get slur direction
-c
- slurudq = 'u'
- if (.not.beamon(ivx)) then
- if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
- * nvmx(iv),ivx,nv) .eq. 'u') slurudq = 'd'
- else
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') slurudq = 'd'
- end if
-c
-cc Replace ndxslur by 11-ndxslur when printing only.
-c Replace ndxslur by 23-ndxslur when printing only.
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c notexq = sq//'islur'//slurudq//chax(59-ndxslur)
- notexq = sq//'islur'//slurudq//chax(71-ndxslur)
- * //noteq(1:lnoten)
- call addstr(notexq,8+lnoten,soutq,lsout)
- else if (23-ndxslur .lt. 20) then
- notexq = sq//'islur'//slurudq//'{1'//chax(61-ndxslur)
- * //'}'//noteq(1:lnoten)
- call addstr(notexq,11+lnoten,soutq,lsout)
- else
- notexq = sq//'islur'//slurudq//'{2'//chax(51-ndxslur)
- * //'}'//noteq(1:lnoten)
- call addstr(notexq,11+lnoten,soutq,lsout)
- end if
-c call setbits(ipl(ivx,ip),4,23,ndxslur)
- call setbits(ipl(ivx,ip),5,23,ndxslur)
- if (btest(ipl(ivx,ip),31))
-c
-c Starting slur on W-grace on THIS note. Record ndxslur.
-c
- * listslur = ibset(listslur,ndxslur)
- end if
- end if
-c
-c Process dynamic marks
-c
- if (btest(irest(ivx,ip),26)) then
- call dodyn(ivx,ip,
- * nolev(ivx,ip),ncmid(iv,ip),ipl(ivx,ip),islur(ivx,ip),
- * irest(ivx,ip),nvmx(iv),nv,beamon(ivx),ihornb,nornb,ulq,
- * ibmcnt(ivx),nodur(ivx,ip).ge.64,soutq,lsout)
- end if
-c
-c Check for chord notes. Moved up from below, 10/27/96 so chord orns done 1st.
-c
- if (btest(ipl(ivx,ip),10)) then
-c
-c Need a duration to set type of note head
-c
-c Clumsy test, but vxtup is not set until main note is processed.
-c
- if (.not.(vxtup(ivx).or.btest(irest(ivx,ip),28))) then
- nodu = nodur(ivx,ip)
- else if (btest(irest(ivx,ip),2) .or.
- * (ip.gt.1.and.btest(irest(ivx,ip-1),2))) then
-c
-c In a 2-note tremolo
-c
- if (btest(irest(ivx,ip),2)) then
-c
-c First note of tremolo, duration is on next note
-c
- nodu = nodur(ivx,ip+1)
- else
- nodu = nodur(ivx,ip)
- end if
- else if (iand(mult(ivx,ip),15)-8 .lt. 0) then
- nodu = 32
- else
- nodu = 16
- end if
- call docrd(ivx,ip,nodu,ncmid(iv,ip),iv,tnow,soutq,lsout,
- * ulq,ibmcnt(ivx),islur(ivx,ip),nvmx(iv),nv,
- * beamon(ivx),nolev(ivx,ip),ihornb,nornb,stemlen,
- * btest(nacc(ivx,ip),27),nacc(ivx,ip),
- * irest)
- end if
-c
-c Now that chords are done, add stuff to midi file
-c
- if (ismidi) call addmidi(icm,
-c 130316
- * nolev(ivx,ip)+miditran(instno(iv)),
- * iand(nacc(ivx,ip),7),midisig,
- * tnote(ipl2(ivx,ip)),
- * btest(irest(ivx,ip),0),.false.)
-c
-c Check for breath or caesura
-c
- if (btest(iornq(ivx,ip),28)) then
- call putcb(ivx,ip,notexq,lnote)
- call addstr(notexq,lnote,soutq,lsout)
- end if
-c
-c Check for main-note ornaments. ')' on dotted notes go in with note, not here.
-c Bits 0-13: (stmgx+Tupf._) ; 14: Down fermata, was F
-c 15: Trill w/o "tr", was U , 16-18 edit. accid., 19-21 TBD
-c
-c isacc = iand(iornq(ivx,ip),4194287) .gt. 0
-c isacc = iand(iornq(ivx,ip),541065199) .gt. 0
- isacc = iand(iornq(ivx,ip),1614807023) .gt. 0
-c
-c isacc=.true. if any ornament except segno
-c
- if (btest(iornq(ivx,ip),13) .and. nodur(ivx,ip).gt.0) then
-c
-c If ). is only ornament, bypass. If with others, temporarirly zero the bit.
-c
- if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then
- if (iand(iornq(ivx,ip),516079) .eq. 0) then
-c
-c ). is the only non-segno ornament
-c
- isacc = .false.
- else
-c
-c There are other ornaments in addition
-c
- rpndot = .true.
- iornq(ivx,ip) = ibclr(iornq(ivx,ip),13)
- end if
- end if
- end if
- if (isacc .and. .not.cwrferm(ivx)) then
-c
-c Check for centered whole-bar rest with fermata (bits 10 or 14).
-c
- if (iand(iornq(ivx,ip),17408).gt.0
- * .and. btest(irest(ivx,ip),0) .and.
- * nodur(ivx,ip).eq.lenbar .and.
- * .not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)) then
- cwrferm(ivx) = .true.
- go to 30
- end if
- call putorn(iornq(ivx,ip),nolev(ivx,ip),nolev(ivx,ip),
- * nodur(ivx,ip),nornb,ulq,ibmcnt(ivx),ivx,ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),nv,ihornb,stemlen,
- * notexq,lnote,ip,islhgt,beamon(ivx),
- * btest(ipl(ivx,ip),10))
- call addstr(notexq,lnote,soutq,lsout)
- end if
- if (rpndot) then
- iornq(ivx,ip) = ibset(iornq(ivx,ip),13)
- rpndot = .false.
- end if
-30 continue
-c
-c Check for main note accidental
-c
- if (iand(nacc(ivx,ip),3).gt.0 .and.
- * .not.btest(nacc(ivx,ip),17)) then
- ihshft = igetbits(nacc(ivx,ip),7,10)
- if (ihshft .ne. 0) ihshft=ihshft-107
- if (.not.btest(ipl(ivx,ip),10) .and. btest(ipl(ivx,ip),8))
-c
-c Not a chord, and left-shifted main note, so left-shift accid
-c
- * ihshft = ihshft-20
- call doacc(ihshft,igetbits(nacc(ivx,ip),6,4),
- * notexq,lnote,nacc(ivx,ip),nolev(ivx,ip),ncmid(iv,ip),
- * btest(irest(ivx,ip),31))
- call addstr(notexq,lnote,soutq,lsout)
- end if
-c
-c Lower dot for lower-voice notes. Conditions are:
-c 1. Dotted time value
-c 2. Lower voice of two
-c 3. Note is on a line
-c 4. Not a rest
-c. 5. Flag (lowdot) is set to true
-c 6. Not in an xtuplet
-c
- if (lowdot .and. nvmx(iv).eq.2 .and. ivx.le.nv
- * .and. nodur(ivx,ip).ne.0) then
- if (.not.btest(irest(ivx,ip),0) .and.
- * 2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip) .and.
- * mod(nolev(ivx,ip)-ncmid(ivx,ip),2).eq.0) then
- if (btest(irest(ivx,ip),19)) then
-c
-c Note already in movdot list. Drop by 2.
-c
- updot(ivx,ndotmv(ivx)+1) =
- * updot(ivx,ndotmv(ivx)+1)-2.
- else
-c
-c Not in list so just move it right now
-c
- call dotmov(-2.,0.,soutq,lsout,
- * igetbits(islur(ivx,ip),1,3))
- end if
- end if
- end if
-c
-c Check for dotted main notes with moved dots. Chord notes done elsewhere.
-c Added check rules out special chordal 2nds, but later must check
-c substituted chord note for dot shift that now applies to main note.
-c
- if (btest(irest(ivx,ip),19)) then
- ndotmv(ivx) = ndotmv(ivx)+1
- call dotmov(updot(ivx,ndotmv(ivx)),rtdot(ivx,ndotmv(ivx)),
- * soutq,lsout,igetbits(islur(ivx,ip),1,3))
- end if
-c
-c Stemlength changes
-c
- if (btest(mult(ivx,ip),27)) then
- dstemlen = igetbits(mult(ivx,ip),6,10)*.5-4.
- call addstr(sq//'stdstemfalse',13,soutq,lsout)
- stemshort = 4.66+.667*dstemlen
- call addstr(sq//'stemlength{',12,soutq,lsout)
- write(notexq,'(f4.1)')stemshort
- call addstr(notexq(1:4)//'}',5,soutq,lsout)
- else if (ip .gt. 1) then
- if (btest(mult(ivx,ip-1),27))
-c
-c Cancel shortening. Looks like it gets automatically restored if new inst. or
-c new line, so no need to worry about affecting other lines
-c
- * call addstr(sq//'stemlength{4.66}',17,soutq,lsout)
- end if
-c
-c Zero out slur-height marker for raising ornaments
-c
- islhgt = 0
-c
-c Now start with spacing notes. Is a beam start pending?
-c
- if (bspend .and.
- * ibm2(ivx,ibmcnt(ivx)).gt.ibm1(ivx,ibmcnt(ivx))) then
- if (ixrest(ivx) .eq. 4) then
-c
-c Special path for single note at end of otherwise beamed xtup
-c
- ixrest(ivx) = 0
- else
- if (kbdrests .and. btest(irest(ivx,ip),0) .and.
- * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and.
- * nolev(ivx,ip).le.50)
- * call chkkbdrests(ip,iv,ivx,nn,islur,irest,nolev,
- * ivmx,nib,nv,ibar,tnow,tol,nodur,2,levtopr,levbotr,
- * mult,ipl)
- if (btest(islur(ivx,ip),29)
- * .and.btest(irest(ivx,ip),24)) then
- notexq = chax(92)//'sk'
- lnote = 3
- else
- call beamn1(notexq,lnote)
-c if (isbjmp .and.
- if (isbjmp .and. ivbj2.ne.0 .and.
- * iand(mult(ivx,ip),15)-8 .gt. multbj1) then
-c
-c Need to increase multiplicity at the beam jump
-c
-c ibmcnt was increased by 1 at the end of first seg of jump beam!?
-c Try adding e.g. \nbbu1 if needed to increase multiplicity. Add
-c character in reverse order to start of notexq.
-c
- if (ivbj1 .lt. 9) then
- notexq = char(48+ivbj1)//notexq(1:lnote)
- lnote = lnote+1
- else
- notexq = '{1'//char(38+ivbj1)//'}'
- * //notexq(1:lnote)
- lnote = lnote+4
- end if
- notexq = 'bb'//ulq(ivbj1,ibmcnt(ivbj1)-1)
- * //notexq(1:lnote)
- lnote = lnote+3
- if (iand(15,mult(ivx,ip))-8 .eq. 3) then
- notexq = 'b'//notexq(1:lnote)
- lnote = lnote+1
- end if
- notexq = sq//'n'//notexq(1:lnote)
- lnote = lnote+2
- end if
- end if
- end if
- bspend = .false.
-c
-c Is a beam ending?
-c
- else if (numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx)
- * .and. (ibm2(ivx,ibmcnt(ivx)).eq.ip .or.
- * btest(nacc(ivx,ip),20))) then
- if (bspend) then
-c
-c Must be a single-note ending of a jump-beam
-c
- bspend = .false.
- end if
- call beamend(notexq,lnote)
- if (isbjmp .and. ivx.eq.ivbj1) then
-c
-c Jump beam segment is ending, check if multiplicity DECREASES
-c
- if (space(ib+1) .gt. space(ib)) then
-c
-c Decrease multiplicity 3-1, 3-2, or 2-1. Spaces are 2,4, or 8.
-c
- if (ivx .lt. 10) then
- ivxq = char(ivx+48)
- livx = 1
- else
- ivxq = '{1'//char(ivx-10)//'}'
- livx = 4
- end if
-c Changes to get staffcrossall.pmx to work. Not clear how.
-c if (nint(space(ib+1)-space(ib)) .eq. 6) then
- if (space(ib+1).eq.8..and.space(ib).eq.2.) then
- notexq = sq//'tbbb'//ulq(ivx,ibmcnt(ivx))//
- * ivxq(1:livx)//sq//'tbb'//
- * ulq(ivx,ibmcnt(ivx))//ivxq(1:livx)//notexq(1:lnote)
- lnote = lnote+11+2*livx
-c else if (nint(space(ib+1)-space(ib)) .eq. 4) then
- else if (space(ib+1).eq.8..and.space(ib).eq.4.) then
- notexq = sq//'tbb'//ulq(ivx,ibmcnt(ivx))//
- * ivxq(1:livx)//notexq(1:lnote)
- lnote = lnote+5+livx
-c else
- else if (space(ib+1).eq.4..and.space(ib).eq.2.) then
- notexq = sq//'tbbb'//ulq(ivx,ibmcnt(ivx))//
- * ivxq(1:livx)//notexq(1:lnote)
- lnote = lnote+6+livx
- end if
- end if
- end if
- if (.not.btest(nacc(ivx,ip),20)) then
- vxtup(ivx) = .false.
- nornb(ivx) = 0
- ibmcnt(ivx) = ibmcnt(ivx)+1
- beamon(ivx) = .false.
- end if
-c
-c Or if we're in the middle of a beam
-c
- else if (numbms(ivx).gt.0 .and. beamon(ivx)) then
-c
-c Added 130127
-c
- if (kbdrests .and. btest(irest(ivx,ip),0) .and.
- * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and.
- * nolev(ivx,ip).le.50)
- * call chkkbdrests(ip,iv,ivx,nn,islur,irest,nolev,
- * ivmx,nib,nv,ibar,tnow,tol,nodur,2,levtopr,levbotr,
- * mult,ipl)
- call beamid(notexq,lnote)
-c
-c Or whole-bar rest
-c
- else if (btest(irest(ivx,ip),0)
- * .and. nodur(ivx,ip).eq.lenbar
- * .and..not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)
- * .and..not.btest(irest(ivx,ip),25)
- * .and..not.btest(islur(ivx,ip),29)) then
-c
-c Rule out pickup bar, blank rests, non-centered. Remember islur b19=> rp
-c
- cwrest(ivx) = .true.
- iscwr = .true.
- call notex(cwrq(ivx),lcwr(ivx))
- tnow = tnow+lenbar
- go to 10
- else if (ixrest(ivx) .eq. 0) then
-c
-c Before writing note or rest, check for keyboard rest height adjustment.
-c Conditions are 0. This is a non-blank rest
-c 1. kbdrests = .true.
-c 2. There are two voices on the staff
-c 3. No user-def height adjustments have been applied (nolev<50)
-c
- if (kbdrests .and. btest(irest(ivx,ip),0) .and.
- * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and.
- * nolev(ivx,ip).le.50) then
- call chkkbdrests(ip,iv,ivx,nn,islur,irest,nolev,
- * ivmx,nib,nv,ibar,tnow,tol,nodur,1,levtopr,levbotr,
- * mult,ipl)
- end if
- if (btest(ipl(ivx,ip),4)) then
-c
-c Deal with single stem tremolo
-c Get up-downness, borrowed from notex
-c
- if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
- * nvmx(iv),ivx,nv).eq.'u') then
- udq = 'u'
- else
- udq = 'l'
- end if
- multtrem = igetbits(ipl(ivx,ip),2,5)+1
- if (nodur(ivx,ip) .lt. 64) then
- notexq = sq//'tr'
- else
- notexq = sq//'Tr'
- end if
- lnote = 3
- if (multtrem .eq. 2) then
- notexq = notexq(1:3)//'r'
- lnote = 4
- else if (multtrem .eq.3) then
- notexq = notexq(1:3)//'rr'
- lnote = 5
- end if
-c
-c Get a numerical pitch argument
-c
- lineno = nolev(ivx,ip)-ncmid(iv,ip)+4
- if (lineno .lt.0 .or. lineno .gt.9) then
- write(noteq,'(a1,i2,a1)')'{',lineno,'}'
- lnoten = 4
- else
- noteq = char(lineno+48)
- lnoten = 1
- end if
- notexq = notexq(1:lnote)//'m'//udq//noteq(1:lnoten)
- lnote = lnote+2+lnoten
- call addstr(notexq,lnote,soutq,lsout)
- end if
-c
-c Get code for a separate note or rest
-c If nacc(ivx,ip)(30-31)=1 (dotted chordal 2nd including main note),
-c pitch will be shifted +/-1 inside notex.
-c
- call notex(notexq,lnote)
- end if
-c
-c Right offset? This may cause trouble
-c
- if (btest(ipl(ivx,ip),8)) then
- call addstr(sq//'loff{',6,soutq,lsout)
- else if (btest(ipl(ivx,ip),9)) then
- call addstr(sq//'roff{',6,soutq,lsout)
- end if
- if (ixrest(ivx).eq.0 .and. lnote.gt. 0) then
- call addstr(notexq,lnote,soutq,lsout)
- end if
- if (btest(ipl(ivx,ip),8) .or.
- * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout)
-c
-c Terminate user-defined offsets. Fix format
-c
- if (btest(irest(ivx,ip),15) .or. btest(irest(ivx,ip),17))
- * call putshft(ivx,.false.,soutq,lsout)
-c
-c Deal with After- and Way-after-graces. First, if end of bar, compute space
-c needed since it wasn't done during general ask-checks. If extra space is
-c rq'd, convert GW to GA. Therefore GW at end of bar never needs extra sp.
-c But will still need to add extra space as hardspace.
-c
- if (ip.eq.nn(ivx) .and. (btest(ipl(ivx,ip),31).or.
- * btest(ipl(ivx,ip),29))) then
- do 77 ig = 1 , ngrace
- if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 78
-77 continue
- print*,'Problem finding grace index at "do 77"'
- call stop1()
-78 continue
-c
-c Get elemskip to end of bar. WON'T WORK IF XTUPS !!
-c
- esk = 0.
- do 40 iib = ib , nb
- if (iib .eq. ib) then
- itleft = nint(to(ipl2(ivx,ip)))
- else
- itleft = nint(tstart(ib))
- end if
- if (iib .lt. nb) then
- itright = nint(tstart(iib+1))
- else
- itright = lenbar
- end if
- esk = esk+feon(space(ib))*
- * (itright-itleft)/space(ib)
-40 continue
- ptsavail = poenom*esk-wheadpt
- if (nng(ig) .eq. 1) then
- wgr = grafac
- else
- wgr = nng(ig)*emgfac
- do 41 ing = 1 , nng(ig)
- if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac
-41 continue
- end if
- ptgr(ig) = wgr*wheadpt
- ptsneed = (wgr+0.5)*wheadpt
- ptsndg(ivx) = 0.
- if (ptsavail .lt. ptsneed) then
- ptsndg(ivx) = ptsneed
- eskndg(ivx) = esk
- if (btest(ipl(ivx,ip),31)) then
-c
-c Convert GW to GA
-c
- ipl(ivx,ip) = ibset(ibclr(ipl(ivx,ip),31),29)
- end if
- end if
- end if
-c
-c Check for GA
-c
- if (btest(ipl(ivx,ip),29))
- * call dograce(ivx,ip,ptgr,soutq,lsout,ncmid(iv,ip),
- * nacc(ivx,ip),ig,ipl(ivx,ip),.false.,
-c 130324
-c * .false.,0,0,0,0,0,0,0.,ulq)
- * .false.,0,0,0,0,0,0,0.,ulq,instno(iv))
-c
-c Update running time
-c
- tnow = tnow+space(ib)
-10 continue
-c
-c Have finished last note in this voice and block
-c
- itendb = nint(to(istop(ib))+space(ib))
- if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then
- ivf = 1
- if (ivx .gt. 1) ivf = 2
-17 if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.itendb) then
-c
-c There's at least one figure left. offnsk could be <0
-c
- offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib)
- call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq,lsout)
- go to 17
- end if
- end if
-c
-c Check for flag, dot, or upstem on last note of bar.
-c
- if (ib .eq. nb) then
- ip = ipo(ipl2(ivx,nn(ivx)))
- flgndv(ivx) = 0.
- if (abs(tnote(ipl2(ivx,ip))-space(ib)).lt.tol) then
- if (space(ib) .lt. 16.-tol) then
-c
-c Note in last space, smaller than a quarter note.
-c
- if ((.not.btest(irest(ivx,ip),0) .and.
- * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
- * nvmx(iv),ivx,nv).eq.'u')
- * .or. isdotted(nodur,ivx,ip)) then
-c
-c Upstem non-rest, or dotted
-c
- if (numbms(ivx).gt.0
- * .and. ip.eq.ibm2(ivx,max(1,numbms(ivx)))
- * .and. .not.isdotted(nodur,ivx,ip))
- * then
-c
-c In beam and not dotted, so use smaller space
-c
- flgndv(ivx) = upstmfac
- else
- flgndv(ivx) = flagfac
- end if
- end if
- else
-c
-c Last space, nonflagged (no beam) only worry dot or up
-c
- if (isdotted(nodur,ivx,ip)) then
- flgndv(ivx) = flagfac
- else if (tnote(ipl2(ivx,ip)).lt.64 .and.
- * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
- * nvmx(iv),ivx,nv).eq.'u') then
-c
-c Upstem on last note , non-flagged
-c
- flgndv(ivx) = upstmfac
- end if
- end if
- end if
-c
-c Check for right-shifted chordal note
-c
- if (btest(irest(ivx,ip),20)) flgndv(ivx) = rtshfac
- flgndb = flgndb .or. flgndv(ivx).gt.0.
- if (ismidi) then
-c
-c For midi, set flags for accidentals on last note of bar. Assume they affect
-c first note of next bar whether or not tied.
-c Note has already been done, so next entry into addmidi is 1st in new bar.
-c First do main note, then chord notes
-c
-c Gyrations needed to account for multi-bar tied full-bar notes?
-cc Old old lbacc(icm) = iand(nacc(ivx,ip),7)
-c New old if (lbacc(icm).eq.0) lbacc(icm) = iand(nacc(ivx,ip),7)
-c
- if (iand(nacc(ivx,ip),7) .gt. 0) then
-c
-c Explicit accidental on last main note in bar
-c
- do 55 kacc = 1 , naccbl(icm)
- if (laccbl(icm,kacc) .eq. nolev(ivx,ip)) go to 56
-55 continue
- naccbl(icm) = naccbl(icm)+1
- laccbl(icm,naccbl(icm)) = nolev(ivx,ip)
- jaccbl(icm,naccbl(icm)) = iashft(iand(nacc(ivx,ip),7))
- end if
-56 continue
- if (btest(ipl(ivx,ip),10) .and. crdacc) then
- do 57 icrd = icrd1 , icrd2
- iacc = igetbits(icrdat(icrd),3,20)
- if (iacc .gt. 0) then
-c
-c Explicit accidental on chord note at end of bar
-c
- nolevc = igetbits(icrdat(icrd),7,12)
- do 58 kacc = 1 , naccbl(icm)
- if (laccbl(icm,kacc) .eq. nolevc) go to 59
-58 continue
- naccbl(icm) = naccbl(icm)+1
- laccbl(icm,naccbl(icm)) = nolevc
- jaccbl(icm,naccbl(icm)) = iashft(iacc)
- end if
-59 continue
-57 continue
- end if
-c if (lbacc(icm).eq.0 .and. accb4(icm)) then
- do 65 kacc = 1 , naccim(icm)
-c
-c If naccim(icm)>0,
-c possible implicit accidental from earlier in the bar. Check for prior accid
-c in this bar at relevant note levels, main and chord notes. Only act if no
-c explicit action from just above. Assuming any accid on last note in bar,
-c either explicit or implicit, has same effect on 1st note of next bar.
-c
- if (nolev(ivx,ip) .eq. laccim(icm,kacc)) go to 66
- if (btest(ipl(ivx,ip),10)) then
- do 67 icrd = icrd1 , icrd2
- if (iand(ishft(icrdat(icrd),-12),127) .eq.
- * laccim(icm,kacc)) go to 66
-67 continue
- end if
- go to 65
-66 continue
-c
-c So far we know there is a main or chord note at level laccim(icm,kacc). So
-c it will get a bl-accid if it didn't just already get one.
-c
- do 68 macc = 1 , naccbl(icm)
- if (laccbl(icm,macc) .eq. laccim(icm,kacc)) go to 65
-68 continue
- naccbl(icm) = naccbl(icm)+1
- laccbl(icm,naccbl(icm)) = laccim(icm,kacc)
- jaccbl(icm,naccbl(icm)) = jaccim(icm,kacc)
-65 continue
- end if
- end if
-11 continue
-c
-c Close out the notes group
-c
- call addstr(sq//'en',3,soutq,lsout)
- if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%'
-16 continue
-c
-c Check for way-after graces at end of bar. We could not link these to notes
-c as in midbar since there is no note following grace! Also, set flag if
-c hardspace is needed. Also, save nvmx, ivmx for use in space checks on reloop.
-c
- isgrace = .false.
- do 75 iv = 1 , nv
- nvmxsav(iv) = nvmx(iv)
- do 75 kv = 1 , nvmx(iv)
- ivmxsav(iv,kv) = ivmx(iv,kv)
- ivx = ivmx(iv,kv)
- ptsgnd = 0.
- if ((btest(ipl(ivx,nn(ivx)),29).or.btest(ipl(ivx,nn(ivx)),31))
- * .and. ptsndg(ivx).gt.0.) then
- flgndb = .true.
- if (ptsndg(ivx) .gt. ptsgnd) then
- ptsgnd = ptsndg(ivx)
- eskgnd = eskndg(ivx)
- end if
- end if
- if (btest(ipl(ivx,nn(ivx)),31)) then
-c
-c This voice has a way-after grace here at end of bar
-c
- if (.not.isgrace) then
-c
-c This is the first one, so set up the string
-c
- isgrace = .true.
- ivlast = 1
- soutq = sq//'znotes'
- lsout = 7
- end if
- do 76 iiv = ivlast , iv-1
- call addstr(sepsymq(iiv),1,soutq,lsout)
-76 continue
- ivlast = iv
-c
-c No need to put in 'nextvoice', even if 2 lines/staff
-c
- call dograce(ivx,nn(ivx),ptgr,soutq,lsout,ncmid(iv,nn(ivx)),
- * nacc(ivx,nn(ivx)),ig,ipl(ivx,nn(ivx)),.true.,
-c 130324
-c * .false.,0,0,0,0,0,0,0.,ulq)
- * .false.,0,0,0,0,0,0,0.,ulq,instno(iv))
- end if
-75 continue
- if (isgrace) then
- call addstr(sq//'en%',4,soutq,lsout)
- if (islast .and. lsout .gt. 0) write(11,'(a)')soutq(1:lsout)
- end if
- lsout = 0
-c
-c Write multibar rest. Assuming nv = 1 and do not worry about cwbrest
-c This has to be the only use of atnextbar
-c
- if (ibar.eq.ibarmbr .and. islast) then
- if (newmbrhgt) then
- soutq = sq//'def'//sq//'mbrhgt{'
- if (mbrhgt .le. -10) then
- write(soutq(13:15),'(i3)')mbrhgt
- lsout = 15
- else if (mbrhgt.ge.10.or.mbrhgt.le.-1) then
- write(soutq(13:14),'(i2)')mbrhgt
- lsout = 14
- else
- soutq = soutq(1:12)//char(48+mbrhgt)
- lsout = 13
- end if
- soutq = soutq(1:lsout)//'}%'
- write(11,'(a)')soutq(1:lsout+2)
- newmbrhgt = .false.
- end if
- soutq = sq//'def'//sq//'atnextbar{'//sq//'znotes'
- lsout = 22
- notexq = sq//'mbrest'
- lnote = 7
- call istring(mbrest,noteq,len)
- notexq = notexq(1:lnote)//noteq(1:len)
- lnote = lnote+len
- mtrspc = nint(xb4mbr)
- xb4mbr = 0.
- call istring(mtrspc,noteq,len)
- notexq = notexq(1:lnote)//noteq(1:len)//'0'
- lnote = lnote+len+1
- do 62 iv = 1 , nv
- call addstr(notexq,lnote,soutq,lsout)
- if (iv .lt. nv) call addstr(sepsymq(iv),1,soutq,lsout)
-62 continue
- call addstr(sq//'en}%',5,soutq,lsout)
- write(11,'(a)')soutq(1:lsout)
- lsout = 0
- if (ishort .gt. 0) then
- mbrsum = mbrsum+mbrest
- nmbr = nmbr+1
- end if
- if (mbrest .gt. 1) then
- ndig = int(alog10(mbrest-1+.01))+1
- write(11,'(a14,i'//chax(48+ndig)//',a1)')
- * sq//'advance'//sq//'barno',mbrest-1,'%'
- end if
- else if (iscwr) then
-c
-c Centered whole-bar rests. Set flag to pass to pmxb at start of NEXT bar
-c to check for new clef and add space by redefining \CenterBar
-c
- centrests = .true.
- call addstr(sq//'def'//sq//'value{0}',13,soutq,lsout)
- call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes',22,
- * soutq,lsout)
- do 60 iv = 1 , nv
-c added
- lnote = 0
-c
- do 61 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- if (cwrest(ivx)) then
- call addstr(sq//'CenterBar{',11,soutq,lsout)
- if (.not.cwrferm(ivx)) then
- if (lcwr(ivx).ge.11 .and. cwrq(ivx)(11:11).ne.'p') then
-c
-c Kluge to use new definitions for centered, stacked rests
-c
- if (cwrq(ivx)(2:10).eq.'liftpause' .or.
- * cwrq(ivx)(2:10).eq.'liftPAuse')
- * cwrq(ivx)(10:10) = 'c'
- end if
- call addstr(cwrq(ivx)(1:lcwr(ivx)),lcwr(ivx),soutq,
- * lsout)
- call addstr('}{-2}{'//sq//'value}',13,soutq,lsout)
- else
-c
-c Fermata on centered rest. Will need to fix up level.
-c 12/6/07 shift it left so it's centered over rest
-c
- notexq = notexq(1:lnote)//sq//'loffset{.33}{'
- * //sq//'fermataup7}'//cwrq(ivx)(1:lcwr(ivx))
- * //'}{-2}{'//sq//'value}'
- lnote = lnote+26+lcwr(ivx)+13
- call addstr(notexq,lnote,soutq,lsout)
- cwrferm(ivx) = .false.
- end if
- end if
-61 continue
- if (iv .ne. nv) call addstr(sepsymq(iv),1,soutq,lsout)
-60 continue
- if (islast) then
- call addstr(sq//'en}%',5,soutq,lsout)
- if (lsout.gt.0)write(11,'(a)')soutq(1:lsout)
- end if
- end if
-c
-c End of block for centered whole-bar rests and multi-bar rests
-c
-c If at end of block, save durations of last notes in bar, for possible use
-c if clef changes at start of next bar
-c
- if (ibar .eq. nbars) then
- do 63 iv = 1 , nv
- do 63 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- prevtn(ivx) = tnote(ipl2(ivx,nn(ivx)))
-63 continue
- end if
-c
-c Update time for midi. This is only used for the event track
-c
- if (ismidi) then
- miditime = miditime+15*lenbar
-c
-c If pickup, write the real time signature to the event track. Cannot use
-c mtrnuml since it was reset to 0, have to recompute it
-c
- if (lenb0 .eq. lenbar)
- * call midievent('m',mtrdenl*lenb1/64,mtrdenl)
- end if
- return
- end
- subroutine makeabar()
-c
-c On input, have pseudo-durations in nodur(ivx,ip). Not real durations for
-c xtups, since only last note of xtup gets non-zero nodur, which
-c corresponds to single note of full length of xtup.
-c In this subroutine we make an ordered list of all notes in all voices.
-c ilnc = list note counter
-c ivxo(ilnc), ipo(ilnc) = voice# and position in voice of ilnc-th note.
-c to(ilnc) = real start time of note in PMX-units (64=whole note)
-c tno(ilnc) = time to next event in the bar.
-c tnote(ilnc) = actual duration of note
-c Then run thru list, grouping consecutive notes into \notes groups ib.
-c space(ib) = real time unit for the \notes group
-c squez(ib) = factor on space to get effective space. This will be 1 if
-c there is a note exactly spanning each interval of space, and
-c <1 if not.
-c Details: let eon = elemskips per noteskip (like length). Basic formula is
-c eon = sqrt(space/2.)
-c If tgovern >= space, then
-c eon = sqrt(tgovern/2)*(space/tgovern) = space/sqrt(2*tgovern).
-c Time needed to give this eon using basic formula is
-c teq = space**2/tgovern
-c Factor on space to get teq is
-c squez(ib) = space/tgovern
-c The eon for each ib can then be computed based on time of space*squez.
-c Iff squez = 1, there is a note spanning every increment in the \notes group.
-c
-c tnminb = minimum time span in the bar for increments spanned by notes,
-c i.e., with squez=1. Use after parsing into line to decide if
-c spacing needs to be "flattened" among notes groups.
-c
- common /comtol/ tol
- parameter (nm=24,nkb=3999,maxblks=9600)
- common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm),
- * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
- * nbars,itsofar(nm),nib(nm,15),nn(nm),
- * rest(nm,200),lenbr0,lenbr1,firstline,newmeter
- common /linecom/ elskb,tnminb(nkb)
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
-c * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- * ibaroff,udsp(nkb),wheadpt,sqzb(maxblks)
- common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200)
-c logical rest,firstline,newmeter,gotclef
- logical rest,firstline,newmeter
- integer cnn(nm),istart(80),istop(80)
- real*4 xit(nm),space(80),tstart(80),squez(80),tnote(600)
- elskb = 0.
- tnminb(ibarcnt) = 1000.
- do 1 iv = 1 , nv
- do 1 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- if (ibar .gt. 1) then
- nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1)
- else
- nn(ivx) = nib(ivx,ibar)
- end if
-1 continue
-c
-c initialize list note counter, time(iv), curr. note(iv)
-c
- ilnc = 1
- do 4 iv = 1 , nv
- do 4 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- cnn(ivx) = 1
- ivxo(ilnc) = ivx
- ipo(ilnc) = 1
- to(ilnc) = 0.
- tnote(ilnc) = fnote(nodur,ivx,1,nacc)
- xit(ivx) = tnote(ilnc)
- if (abs(xit(ivx)-lenbar).lt.tol) xit(ivx) = 1000.
- ilnc = ilnc+1
-4 continue
-c
-c Build the list
-c
-5 continue
-c
-c Determine which voice comes next from end of notes done so far.
-c tmin is the earliest ending time of notes done so far
-c
- tmin = 1000.
- do 6 iv = 1 , nv
- do 6 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- tminn = min(tmin,xit(ivx))
- if(tminn .lt. tmin) then
- tmin = tminn
- ivnext = ivx
- end if
-6 continue
- if (tmin .gt. 999.) go to 7
- ivxo(ilnc) = ivnext
- cnn(ivnext) = cnn(ivnext)+1
- ipo(ilnc) = cnn(ivnext)
- to(ilnc) = tmin
-c
-c Check if this voice is done
-c
- tnote(ilnc) = fnote(nodur,ivnext,cnn(ivnext),nacc)
- if (cnn(ivnext) .eq. nn(ivnext)) then
- xit(ivnext) = 1000.
- else
- xit(ivnext) = xit(ivnext)+tnote(ilnc)
- end if
- ilnc = ilnc+1
- go to 5
-7 continue
- ntot = ilnc-1
- if (ntot .gt. 600) then
- call printl(' ')
- call printl('Cannot have more than 600 notes per bar, stopping')
- call stop1()
- end if
- do 8 in = 1 , ntot-1
- tno(in) = to(in+1)-to(in)
-8 continue
- tno(ntot) = fnote(nodur,ivxo(ntot),ipo(ntot),nacc)
- tnote(ntot) = tno(ntot)
-c
-c Debug writes
-c
-c write(*,'()')
-c write(*,'(16i5)')(ivxo(in),in=1,ntot)
-c write(*,'(16i5)')(ipo(in),in=1,ntot)
-c write(*,'(16f5.1)')(to(in),in=1,ntot)
-c write(*,'(16f5.1)')(tno(in),in=1,ntot)
-c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot)
-c write(*,'(16f5.1)')(tnote(in),in=1,ntot)
-c
-c Done w/ list. Initialize loop for building note blocks:
-c
- ib = 1
- istart(1) = 1
- space(1) = 0.
- in = 1
-c
-c Start the loop
-c
-9 continue
- if (in .eq. ntot) then
- if (space(ib) .lt. tol) then
- space(ib) = tno(in)
-c
-c Last gap in bar is spanned by a note, so cannot need a squeeze.
-c
- squez(ib) = 1.
- end if
- istop(ib) = ntot
-c
-c From here flow out of this if block and into block-setup
-c
- else if (space(ib) .lt. tol) then
-c
-c space hasn't been set yet, so tentatively set:
-c
- space(ib) = tno(in)
- if (space(ib) .lt. tol) then
- in=in+1
- else
-c
-c Tentative space tno(in) is non-zero. Set squez, which will be kept (since
-c it is a unique property of the particular increment starting here) :
-c
- squez(ib) = getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- end if
- go to 9
- else if (tno(in+1) .lt. tol) then
-c
-c This is not the last note in the space, so
-c
- in = in+1
- go to 9
- else if (abs(tno(in+1)-space(ib)) .lt. tol) then
-c
-c Next increment has same space. Does it have same squez?
-c
- xsquez = getsquez(in+1,ntot,space(ib),tnote,to)
-c
-c If it does have the same squez, loop, otherwise flow out
-c
- if (abs(xsquez-squez(ib)) .lt. tol) then
-c
-c Keep spacing the same, update tentative stop point
-c
- in = in+1
- istop(ib) = in
- go to 9
- end if
- end if
-c
-c At this point istart, istop, space, and squez are good, so close out block
-c
- tstart(ib) = to(istart(ib))
-c
-c Compute elemskips assuming no flattening to increase min space. The formula
-c is only correct if f1eon(t) = sqrt(t/2); more generally (after possible
-c flattening in pmxb), elsperns = squez*feon(space/squez)
-c
- elsperns = f1eon(space(ib)*squez(ib))
- if (istop(ib) .eq. ntot) then
- nnsk = nint((lenbar-tstart(ib))/space(ib))
- else
- nnsk = nint((to(istop(ib)+1)-tstart(ib))/space(ib))
- end if
- elskb = elskb+elsperns*nnsk
- if (nptr(ibarcnt+1) .gt. nptr(ibarcnt)) then
- call catspace(space(ib),squez(ib),nnsk)
- else
-c
-c This is the first entry for this bar
-c
- nnpd(nptr(ibarcnt)) = nnsk
- durb(nptr(ibarcnt)) = space(ib)
- sqzb(nptr(ibarcnt)) = squez(ib)
- nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
- end if
-c
-c Update minimum space spanned by a note
-c
- if (abs(squez(ib)-1) .lt. tol)
- * tnminb(ibarcnt) = min(tnminb(ibarcnt),space(ib))
- if (istop(ib) .eq. ntot) go to 15
-c
-c End of spatial accounting for now
-c
- ib = ib+1
- istart(ib) = istop(ib-1)+1
- in = istart(ib)
-c
-c Set tentative block space for new block
-c
- space(ib) = tno(in)
- if (space(ib).gt.tol)
- * squez(ib)= getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- go to 9
-15 continue
-c nb = ib
-c
-c Debug writes
-c
-c write(*,'(16i5)')(istart(ib),ib=1,nb)
-c write(*,'(16i5)')(istop(ib),ib=1,nb)
-c write(*,'(16f5.1)')(space(ib),ib=1,nb)
-c write(*,'(16f5.1)')(squez(ib),ib=1,nb)
-c
- return
- end
- subroutine midievent(typeq,in1,in2)
-c
-c We now store "conductor" events in mmidi(numchan,.), and count bytes
-c with imidi(numchan)
-c
- parameter (nm=24,mv=24576)
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /comevent/ miditime,lasttime
- character*1 typeq
- idur = isetvarlen(miditime-lasttime,nbytes)
- imidi(numchan) = imidi(numchan)+nbytes+1
- do 1 i = 1 , nbytes
- mmidi(numchan,imidi(numchan)-i) = mod(idur,256)
- idur = ishft(idur,-8)
-1 continue
- mmidi(numchan,imidi(numchan)) = 255
- if (typeq .eq. 't') then
-c
-c Tempo event. in1 = quarters per minute (integer)
-c
- mmidi(numchan,imidi(numchan)+1) = 5*16+1
- mmidi(numchan,imidi(numchan)+2) = 3
- misperq = nint(60000000./in1)
- do 2 i = 1 , 3
- mmidi(numchan,imidi(numchan)+6-i) = mod(misperq,256)
- misperq = ishft(misperq,-8)
-2 continue
- imidi(numchan) = imidi(numchan)+5
- else if (typeq .eq. 'm') then
-c
-c Meter event. in1=numerator, in2=denom (power of 2)
-c
- mmidi(numchan,imidi(numchan)+1) = 5*16+8
- mmidi(numchan,imidi(numchan)+2) = 4
- mmidi(numchan,imidi(numchan)+3) = in1
- if (in2 .gt. 0) then
- mmidi(numchan,imidi(numchan)+4) = log2(in2)
- else
- mmidi(numchan,imidi(numchan)+4) = 0
- end if
- mmidi(numchan,imidi(numchan)+5) = 24
- mmidi(numchan,imidi(numchan)+6) = 8
- imidi(numchan) = imidi(numchan)+6
- else if (typeq .eq. 'k') then
-c
-c Keychange event. in1 = isig
-c
- mmidi(numchan,imidi(numchan)+1) = 5*16+9
- mmidi(numchan,imidi(numchan)+2) = 2
- mmidi(numchan,imidi(numchan)+3) = mod(256+in1,256)
- mmidi(numchan,imidi(numchan)+4) = 0
- imidi(numchan) = imidi(numchan)+4
- else
- print*,'Program flameout in midievent'
- call stop1()
- end if
- lasttime = miditime
- return
- end
- subroutine moveln(iuin,iuout,done)
- logical done
- character*129 outq
- done = .false.
- read(iuin,'(a)',end=1) outq
- lenout = llen(outq,129)
- write(iuout,'(a)') outq(1:lenout)
- return
-1 done = .true.
- return
- end
- subroutine mrec1(lineq,iccount,ndxm)
-c
-c This is called when (a) macro recording is just starting and
-c (b) at the start of a new line, if recording is on
-c
- parameter (maxblks=9600)
- character*128 lineq,lnholdq
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- character*131072 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- if (.not.mrecord) then
-c
-c Starting the macro
-c
- ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount
- il1mac(macnum) = ilbuf-1
- ic1mac(macnum) = iccount
- mrecord = .true.
- end if
- if (iccount .lt. 128) then
- ndxm = index(lineq(iccount+1:128),'M')
- if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M',
- * 128-iccount)
- if (ndxm .gt. 0) then
-c
-c This line ends the macro.
-c
- ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm
- il2mac(macnum) = ilbuf-1
- mrecord = .false.
- end if
- end if
- return
- end
- function ncmid(iv,ip)
- parameter (nm=24)
- common /all/ mult(nm,200),jv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * maxdotmv(nm),ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtol/ tol
- if (ncc(iv) .eq. 1) then
- ncmid = ncmidcc(iv,1)
- else
- xtime = to(ipl2(ivx,ip))
- do 1 icc = ncc(iv) , 1 , -1
- if (xtime .gt. tcc(iv,icc)-tol) then
- ncmid = ncmidcc(iv,icc)
- return
- end if
-1 continue
- print*,'Problem in ncmid()'
- stop
- end if
- end
- function ncmidf(clefq)
-c
-c Return middle line of a clef
-c
- character*1 clefq
- if (clefq .eq. '8') then
-c
-c treblelowoct; will treat as treble for this purpose
-c
- ncmidf = 35
- else
- ncmidf = 21+index(' b6r5n4a3m2s1t0f7',clefq)/2*2
- end if
- return
- end
- subroutine newvoice(jv,clefq,change)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- character*1 ulfbq,clefq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * maxdotmv(nm),ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- logical change,autofbon
- nvmx(jv) = 1
- ivmx(jv,1) = jv
- itsofar(jv) = 0
- nnl(jv) = 0
- nfb(jv) = 0
- if (firstgulp .or. change) then
- ncmidcc(jv,1) = ncmidf(clefq)
- else
- ncmidcc(jv,1) = ncmidcc(jv,ncc(jv))
- end if
- tcc(jv,1) = 0.
- ncc(jv) = 1
- nudoff(jv) = 0
- ndotmv(jv) = 0
- do 5 j = 1 , 200
- irest(jv,j) = 0
- islur(jv,j) = 0
- ipl(jv,j) = 0
- nacc(jv,j) = 0
- iornq(jv,j) = 0
- mult(jv,j) = 0
- if (jv.le.2) isfig(jv,j) = .false.
-5 continue
- return
- end
- subroutine notefq(noteq,lnote,nolev,ncmid)
-c
-c Returns name of note level with octave transpositions, updates noctup.
-c
- common /comoct/ noctup
- character*8 noteq
- character*1 upcaseq,noteqt,chax
- nupfroma = mod(nolev+1,7)
- iname = 97+nupfroma
- ioctup = (nolev+1)/7-4
- noteqt = chax(iname)
- if (ncmid .eq. 23) noteqt = upcaseq(noteqt)
- if (ioctup .eq. noctup) then
- noteq = noteqt
- lnote = 1
-c
-c Must ALWAYS check if lnote=1 for use with functions requiring a blank
-c
- else if (ioctup .gt. noctup) then
-c
-c Raise octave. Encase in {}
-c
- write(noteq,'(8a1)')'{',(chax(39),i=noctup,ioctup-1),
- * noteqt,'}'
- lnote = 3+ioctup-noctup
- noctup = ioctup
- else
-c
-c Lower octave
-c
- write(noteq,'(8a1)')'{',(chax(96),i=ioctup,noctup-1),
- * noteqt,'}'
- lnote = 3+noctup-ioctup
- noctup = ioctup
- end if
- return
- end
- subroutine notex(notexq,lnote)
-c
-c Returns non-beamed full note name
-c
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,
- * isfig,ispoi,btest,even
- character*1 udq,udqq,chax
- character*4 dotq
- character*2 numq
- character*79 notexq
- character*8 noteq
- character*40 restq
- common /compoi/ ispoi
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2,ivvfig(2,74)
- character*10 figq
- ip = ipo(jn)
- nole = nolev(ivx,ip)
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ip),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ip),31)) then
- nole = nole + 1
- end if
- nodu = nodur(ivx,ip)
- if (.not.btest(irest(ivx,ip),0)) then
- udq = udqq(nole,ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),ivx,nv)
- end if
-c
-c Check figure level
-c
-c if (figbass .and. isfig(ivx,ip)
-c * .and. .not.btest(irest(ivx,ip),0)) then
- if (figbass .and. .not.btest(irest(ivx,ip),0) .and.
- * ((ivx.eq.1.and.isfig(1,ip))
- * .or.(ivx.eq.ivxfig2.and.isfig(2,ip)))) then
- if (udq .eq. 'u' .or. nodu.ge.64) then
-c
-c Upper or no stem, fnole (in noleunits) set by notehead
-c
- fnole = nole
- else
-c
-c Lower stem, fnole set by bottom of stem
-c
- fnole = nole-stemlen
- end if
- zmin = fnole-ncmid(ivx,ip)+4
- if (ivx .eq. 1) then
- ifigdr(1,iline) = max(ifigdr(1,iline),nint(4-zmin))
- else
- ifigdr(2,iline) = max(ifigdr(2,iline),nint(4-zmin))
- end if
- end if
- if (.not.btest(irest(ivx,ip),0)) then
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- if (nodu .eq. 1) then
- notexq =sq//'cccc'//udq//noteq(1:lnoten)
- lnote = lnoten+6
- else if (nodu .eq. 2) then
- notexq =sq//'ccc'//udq//noteq(1:lnoten)
- lnote = lnoten+5
- else if (nodu .eq. 4) then
- notexq =sq//'cc'//udq//noteq(1:lnoten)
- lnote = lnoten+4
- else if (nodu .eq. 8) then
- notexq =sq//'c'//udq//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 16) then
- notexq =sq//'q'//udq//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 32) then
- notexq =sq//'h'//udq//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 64) then
- notexq =sq//'wh'//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 128) then
-c notexq =sq//'zbreve'//noteq(1:lnoten)//sq//'sk'
-c lnote = lnoten+10
- notexq =sq//'breve'//noteq(1:lnoten)
- lnote = lnoten+6
- else
- dotq = 'p'
- ldot = 1
- if (btest(iornq(ivx,ip),13)) then
-c
-c Dotted note with ')' ornament
-c
- dotq='m'
- else if (btest(islur(ivx,ip),3)) then
-c
-c Double dot
-c
- dotq = 'pp'
- ldot = 2
- end if
- if (nodu .ge. 192) then
- notexq =sq//'breve'//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+6+ldot
- else if (nodu .ge. 96) then
- notexq =sq//'wh'//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 48) then
- notexq =sq//'h'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 24) then
- notexq =sq//'q'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 12) then
- notexq =sq//'c'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 6) then
- notexq =sq//'cc'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+4+ldot
- ispoi = .true.
- else
- notexq =sq//'ccc'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+5+ldot
- ispoi = .true.
- end if
- if (dotq(1:1) .eq. 'm') then
-c
-c Need another call to the note, in case the first one has octave shifts
-c
- if (lnoten .eq. 2) then
- notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- end if
- else if (btest(islur(ivx,ip),29)) then
-c
-c Blank rest
-c
- notexq = sq//'sk'
- lnote = 3
- else
-c
-c Non-blank rest
-c
- lnote = 0
- nole = mod(nole+20,100)-20
-c
-c Kluge to get pause symbol for rp:
-c
- if (btest(islur(ivx,ip),19)) nodu = 64
- if (nodu .le. 28) then
-c
-c Normal rest < or = double-dotted quarter
-c
- lrest = 3
- if (nodu .gt. 14) then
- restq =sq//'qp'
- else if (nodu .gt. 7) then
- restq =sq//'ds'
- else if (nodu .gt. 3) then
- restq =sq//'qs'
- else if (nodu .gt. 1) then
- restq =sq//'hs'
- else
- restq =sq//'qqs'
- lrest = 4
- end if
-c
-c Special case for rest at start of F-tuplet inside a forced beam
-c
- if (btest(nacc(ivx,ip),18) .and.
- * btest(nacc(ivx,ip),19)) then
- restq = sq//'pt4'//restq(1:lrest)
- lrest = lrest+4
- end if
- notexq = restq
- lnote = lrest
-c
-c At this point notexq=restq,lnote=lrest are name of rest. Now raise if necc.
-c
- if (nole .ne. 0) then
- if (abs(nole) .lt. 10) then
- noteq = chax(48+abs(nole))
- lnoten = 1
- else
- write(noteq(1:2),'(i2)')abs(nole)
- lnoten = 2
- end if
- if (nole .gt. 0) then
- notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote'
- else
- notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote'
- end if
- lnote = 16+lnoten
- notexq = notexq(1:lnote)//restq(1:lrest)
- lnote = lnote+lrest
- end if
- if (2**log2(nodu) .ne. nodu) then
-c
-c Deal with dots (on rests shorter than half rest)
-c
- restq = sq//'pt'
- lrest = 3
- if (2*nodu .gt. 3*2**log2(nodu)) then
- restq = sq//'ppt'
- lrest = 4
- end if
- nole = nole+4
- raisedot = 0
-c
-c Tweak dot positions for special cases
-c
- even = (mod(100+nole,2).eq.0)
-c if (.not.even.and.nodu.gt.8.and.
-c * (nole.lt.0.or.nole.gt.8)) then
- if (.not.even .and. (nole.lt.0.or.nole.gt.8)) then
- raisedot = 1
- end if
- if (nole.ge.10 .or. nole.le.-1) then
- write(numq,'(i2)')nole
- restq = restq(1:lrest)//'{'//numq//'}'
- lrest = lrest+4
- else
- restq = restq(1:lrest)//chax(nole+48)
- lrest = lrest+1
- end if
- if (raisedot.gt.0) then
- restq = sq//'raise'//sq//'internote'//
- * sq//'hbox{'//restq(1:lrest)//'}'
- lrest = lrest+23
- end if
- notexq = restq(1:lrest)//notexq(1:lnote)
- lnote = lnote+lrest
- end if
- else
-c
-c Half rest or longer
-c
- if (nole .eq. 0) then
-c
-c Half or longer rest is not raised or lowered
-c
- if (nodu .le. 56) then
- notexq =sq//'hpause'
- lnote = 7
- else if (nodu .le. 112) then
- if (.not.btest(islur(ivx,ip),19) .or.
- * btest(irest(ivx,ip),25)) then
- notexq = sq//'pause'
- else
- notexq = sq//'pausc'
- end if
- lnote = 6
- else
- notexq =sq//'PAuse'
- lnote = 6
- end if
- if (2**log2(nodu) .ne. nodu) then
-c
-c Dotted rest, hpause or longer
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- if (2*nodu .gt. 3*2**log2(nodu)) then
-c
-c Double dotted long rest
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
- end if
- else
-c
-c Raised or lowered half or whole rest
-c
- if (nodu .eq. 32) then
- notexq = sq//'lifthpause'
- lnote = 11
- else if (nodu .eq. 48) then
- notexq = sq//'lifthpausep'
- lnote = 12
- else if (nodu .eq. 56) then
- notexq = sq//'lifthpausepp'
- lnote = 13
- else if (nodu .eq. 64) then
- notexq = sq//'liftpause'
- lnote = 10
- else if (nodu .eq. 96) then
- notexq = sq//'liftpausep'
- lnote = 11
- else if (nodu .eq. 112) then
- notexq = sq//'liftpausepp'
- lnote = 12
- else if (nodu .eq. 128) then
- notexq = sq//'liftPAuse'
- lnote = 10
- else
-c
-c Assume dotted double whole rest
-c
- notexq = sq//'liftPAusep'
- lnote = 11
- end if
-c
-c Set up height spec
-c
- nole = sign(abs(nole)/2,nole)
- if (nole.le.9 .and. nole.ge.0) then
- noteq = chax(48+nole)
- lnoten = 1
- else
- noteq = '{'
- if (nole .ge. -9) then
- write(noteq(2:3),'(i2)')nole
- lnoten = 3
- else
- write(noteq(2:4),'(i3)')nole
- lnoten = 4
- end if
- noteq = noteq(1:lnoten)//'}'
- lnoten = lnoten+1
- end if
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- end if
- end if
- end if
- return
- end
- function ntindex(line,s2q,lenline)
-c
-c Returns index(line,s2q) if NOT in TeX string, 0 otherwise
-c
- character*(*) s2q,line
- character*1 chax
- logical intex
- ndxs2 = index(line,s2q)
- ndxbs = index(line,chax(92))
- if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then
- ntindex = ndxs2
- else
-c
-c There are both bs and s2q, and bs is to the left of sq2. So check bs's to
-c right of first: End is '\ ', start is ' \'
-c
- len = lenstr(line,lenline)
- intex = .true.
- do 1 ic = ndxbs+1 , len
- if (ic .eq. ndxs2) then
- if (intex) then
- ntindex = 0
- ndxs2 = index(line(ic+1:len),s2q)+ic
- else
- ntindex = ndxs2
- return
- end if
- else if (intex .and. line(ic+1:ic+2).eq.chax(92)//' ') then
- intex = .false.
- else if (.not.intex .and. line(ic+1:ic+2).eq.' '//chax(92))
- * then
- intex = .true.
- end if
-1 continue
- end if
- return
- end
- subroutine ntrbbb(n,char1q,ulqq,iv,notexq,lnote)
-c
-c This appends to notexq e.g. '\ibbbu1'
-c
- common /combbm/ isbbm
- logical isbbm
- character*79 notexq
- character*1 char1q,ulqq,chax
- character*4 tempq
- if (n .ge. 5) isbbm = .true.
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//chax(92)//char1q
- else
- notexq = chax(92)//char1q
- end if
- lnote = lnote+2
- do 3 im = 1 , n
- notexq = notexq(1:lnote)//'b'
- lnote = lnote+1
-3 continue
-c
-c add the number, 0 if 12
-c
-c 5/25/08 Allow >12
-c
-c call istring(mod(iv,12),tempq,len)
- if (iv .lt. 24) then
- call istring(iv,tempq,len)
- else if (iv .eq. 24) then
- tempq(1:1) = '0'
- len = 1
- else
- call printl('Sorry, too man open beams')
- call stop1()
- end if
- notexq = notexq(1:lnote)//ulqq//tempq(1:len)
- lnote = lnote+1+len
- return
- end
- function numclef(clefq)
-c
-c Returns the number to be used as argument of \setclef for MusiXTeX
-c For input 0-6 or tsmanrb return 0-7
-c 7 f 9
-c 8 0
-c
- character*1 clefq
- if (ichar(clefq) .lt. 55) then
-c if (ichar(clefq) .le. 55) then
- numclef = ichar(clefq)-48
-c if (numclef .eq. 7) numclef = 9
- else if (clefq .eq. '7') then
- numclef = 9
- else if (clefq .eq. '8') then
- numclef = 0
- else
- numclef = index('tsmanrbxxf',clefq)-1
- end if
- return
- end
- subroutine outbar(i,jlast)
- character*1 chax
- nfmt = log10(i+.5)+2
- if (jlast+5+nfmt .lt. 80) then
- write(*,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i
- write(15,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i
- jlast = jlast+5+nfmt
- else
- write(*,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i
- write(15,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i
- jlast = 5+nfmt
- end if
- return
- end
- subroutine pmxa(basenameq,lbase,isfirst,nsyout,nbarss,optimize)
-cccccccccccccccccccccccccccccccccccccccccccccccc
-cc cc
-cc Subroutine, combine with pmxb.for
-cc
-cccccccccccccccccccccccccccccccccccccccccccccccc
-cc
-cc Need to consider X spaces in xtuplets when getting poenom, and
-cc maybe fbar?
-cc mx06a
-cc ID numbers for voices when number of voices is reduced.
-cc
-cc mx03a
-cc account for new fracindent for new movements.
-cc
-cc Known changes since pmxa. Version 1.1b (see pmxb for longer list)
-cc
-cc Check ID codes for slurs.
-cc Version 1.24 still does not have details for spacing/positioning
-cc arpeggios if there are accidentals or shifted notes or crowded scores.
-cc Fix problem in 1.22 with arpeggios across multi-line staves
-cc Fix problem in 1.22 with flat key signatures
-cc Read setup data as strings
-cc Warning for octave designation plus +/-
-cc Don't pause for volta warning,
-cc Macros
-cc Correct fsyst to account for transposition and key changes.
-cc Check for nbars > nsyst
-cc
-ccccccccccccccccccccccccccccccccccc
- parameter (nm=24,nkb=3999,nks=125,maxblks=9600)
- logical loop,usefig,isfirst,optimize
- character*131072 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- integer nn(nm),nodur(nm,200),ivxo(600),ipo(600),
- * nnl(nm),itsofar(nm),nib(nm,15),lastbar(0:nks),nbarss(nks)
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
-c * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- * ibaroff,udsp(nkb),wheadpt,sqzb(maxblks)
- common /compage/ widthpt,ptheight,hoffpt,voffpt,
- * nsyst,nflb,ibarflb(0:40),
- * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
- * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30),
- * nistaff(0:40)
- common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1,
- * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS
- real*4 elsk(nkb),celsk(0:nkb),elss(nks),to(600),tno(600)
- character*128 lnholdq
- character*44 basenameq
- logical rest(nm,200),firstline,fbon,isvolt,iskchb,kchmid,ornrpt,
- * stickyS
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,newmeter,newmb(nkb),issegno,bottreb,isheadr,
- * shifton,barend
- common /a1ll/ iv,ivxo,ipo,to,tno,nnl,nv,ibar,mtrnuml,
- * nodur,lenbar,iccount,nbars,itsofar,nib,nn,
- * rest,lenbr0,lenbr1,firstline,newmeter
- common /linecom/ elskb,tnminb(nkb)
- common /cblock/
- * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
- * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh
- common /cominbot/ inbothd
- common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200)
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /commus/ musize,whead20
- common /comeon/ eonk,ewmxk
-c logical mrecord,mplay,endmac,gotclef,cstuplet
- logical mrecord,mplay,endmac,cstuplet
- logical novshrinktop,upslur,fontslur,WrotePsslurDefaults
- common /comnvst/ novshrinktop,cstuplte
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comligfont/ isligfont
- logical isligfont
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- logical fulltrans
- common /comis4bignv/ is4bignv,AIset
- logical is4bignv,AIset
- common /comshort/ shortfrac,codafrac,ishort,mbrsum,nmbr,nocodabn,
- * poefa
- real*4 poefa(125)
- logical nocodabn
- data wtimesig,wclef,wkeysig
- * / 0.72 , 0.8 , 0.28 /
-c data poefa /125*1./
-c This corrected a problem in Bob Tennent's compilation of pmx2.94
-c
- do 97 i = 1 , 125
- poefa(i) = 1.
-97 continue
- is4bignv = .false.
- AIset = .false.
- whead20 = 0.3
- ishort = 0
- if (.not.optimize) then
- print*
- print*,'Starting first PMX pass'
- write(15,'(a)') ' Starting first PMX pass'
- end if
- if (isfirst) then
- open(19,file='pmxaerr.dat')
- write(19,'(i6)') 0
- close(19)
- end if
- if (.not.optimize) jprntb = 81
- macuse = 0
- ornrpt = .false.
- stickyS = .false.
- mrecord = .false.
- mplay = .false.
- lastchar = .false.
- novshrinktop = .false.
- cstuplet = .false.
- fontslur = .true.
- isligfont = .false.
- fulltrans = .false.
- do 42 ibarcnt = 1 , nkb
- udsp(ibarcnt) = 0.
- wminnh(ibarcnt) = -1.
-42 continue
-c
-c Initialize input buffer
-c
- lenbuf0 = ipbuf
- ipbuf = 0
- ilbuf = 1
- call g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
- * xmtrnum0,newkey(1),npages,nsyst,musize,bottreb)
-c
-c Set up list of instrument numbers (iv)
-c
- ivnow = 0
- do 13 instnow = 1 , noinst
- do 14 iscount = 1 , nsperi(instnow)
- ivnow = ivnow+1
- instno(ivnow) = instnow
-14 continue
-13 continue
-c
-c Save initial meter for midi
-c
- if (.not.isfirst .and. npages.eq.0) then
- print*,'Sorry, must have npages>0 for optimization.'
- call stop1()
- end if
- nsyout = nsyst
-c
-c isig1 will be changed in getnote if there is a transposition
-c
- isig1 = newkey(1)
- if (npages .gt. nsyst) then
- call printl('npages > nsyst in input. Please fix the input.')
- call stop1()
- end if
-c
-c fbar = afterruleskip/elemskip
-c apt = width of small accidental + space in points (= 6 at 20pt) =wheadpt
-c
- fbar = 1.
- wheadpt = whead20*musize
- ifig = 0
- usefig = .true.
- lenbeat = i1fnodur(mtrdenl,'x')
- lenmult = 1
- if (mtrdenl .eq. 2) then
- lenbeat = 16
- lenmult = 2
- end if
- lenbr1 = lenmult*mtrnuml*lenbeat
- lenbr0 = nint(lenmult*xmtrnum0*lenbeat)
- mtrnuml = 0
- if (lenbr0 .ne. 0) then
- ibaroff = 1
- lenbar = lenbr0
- else
- ibaroff = 0
- lenbar = lenbr1
- end if
- ibarcnt = 0
- nptr(1) = 1
- iccount = 128
- nmovbrk = 0
- nflb = 0
- nfpb = 0
- ipagfpb(0) = 1
- isysfpb(0) = 1
- ibarflb(0) = 1
- isysflb(0) = 1
- nistaff(0) = nv-1
-c
-c Check for pmx.mod
-c
- linesinpmxmod = 0
-c line1pmxmod = ilbuf
- call getpmxmod(.true.,' ')
- if (.not.isfirst .and. linesinpmxmod .gt. 0) then
- print*,'Sorry, cannot optimize if there is a pmx.mod file'
- call stop1()
- end if
-c
-c Initialize for loop over lines
-c
- nkeys = 1
- ibrkch(1) = 1
- mbrestsav = 0
- shifton = .false.
- firstline = .true.
- newmeter = .false.
- ihead = 0
- isheadr = .false.
-c gotclef = .false.
- idsig = 0
- iddot = 0
- fintstf = -1.
- gintstf = 1.0
- listcresc = 0
- listdecresc = 0
-30 loop = .true.
- iskchb = .false.
- issegno = .false.
- nbars = 0
- ibarmbr = 0
- do 4 iv = 1 , nv
- nvmx(iv) = 1
- ivmx(iv,1) = iv
- itsofar(iv) = 0
- nnl(iv) = 0
- do 5 j = 1 , 200
- rest(iv,j) = .false.
- nacc(iv,j) = 0.
-5 continue
-4 continue
- iv = 1
- ivx = 1
- fbon = .false.
- barend = .false.
- isvolt = .false.
-2 if (loop) then
-c
-c Within this short loop, nv voices are filled up for the duration of a block.
-c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
-c nodur(..),rest(..). nnl will later be
-c increased and things slid around as accidental skips are added.
-c
- call g1etnote(loop,ifig,optimize,fulltrans)
- if (lastchar) go to 20
- go to 2
- end if
- if (mbrestsav .gt. 0) then
- call printl(' ')
- call printl(
- * 'You must enter the same multibar rest in ALL parts')
- call stop1()
- end if
- do 10 ibar = 1 , nbars
- ibarcnt = ibarcnt+1
-c
-c The following is just a signal to start a new bar when cataloging spaces
-c for catspace(...)
-c
- nptr(ibarcnt+1) = nptr(ibarcnt)
- newmb(ibarcnt) = .false.
- if (newmeter.and.ibar.eq.1) newmb(ibarcnt) = .true.
-c
-c Above is only for spacing calcs later on. Remember new meter can only occur
-c at START of a new input line (ibar = 1)
-c
- if (ibar .ne. ibarmbr) then
- if (.not.optimize) call outbar(ibarcnt-ibaroff,jprntb)
- else
- if (.not.optimize) then
- write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1
- write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1
- jprntb = 0
- end if
- ibaroff = ibaroff-mbrest+1
- end if
- if (firstline .and. lenbr0.ne.0) then
- if (ibar .eq. 1) then
- lenbar = lenbr0
- else
- lenbar = lenbr1
- end if
- end if
- if (ibar .gt. 1) then
-c
-c For bars after first, slide all stuff down to beginning of arrays
-c
- do 11 iv = 1 , nv
- do 11 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- ioff = nib(ivx,ibar-1)
- do 12 ip = 1 , nib(ivx,ibar)-ioff
- nodur(ivx,ip) = nodur(ivx,ip+ioff)
- rest(ivx,ip) = rest(ivx,ip+ioff)
- nacc(ivx,ip) = nacc(ivx,ip+ioff)
-12 continue
-11 continue
- end if
- do 67 iv = 1 , nv
- do 67 kv = 1 , nvmx(iv)
- ioff= 0
- if(ibar.gt.1)ioff = nib(ivmx(iv,kv),ibar-1)
-67 continue
- call makeabar()
- elsk(ibarcnt) = elskb+fbar
-10 continue
- newmeter = .false.
- firstline = .false.
- go to 30
-20 continue
-c
-c Vertical analysis.
-c
- if (npages .eq. 0) then
- if (nsyst .eq. 0) then
- print*,'When npages=0, must set nsyst=bars/syst, not 0'
- call stop1()
- end if
- nsyst = (ibarcnt-1)/nsyst+1
- if (nv .eq. 1) then
- nsystpp = 12
- else if (nv .eq. 2) then
- nsystpp = 7
- else if (nv .eq. 3) then
- nsystpp = 5
- else if (nv .eq. 4) then
- nsystpp = 3
- else if (nv .le. 7) then
- nsystpp = 2
- else
- nsystpp = 1
- end if
- npages = (nsyst-1)/nsystpp+1
- end if
-c
-c Check nsyst vs ibarcnt
-c
- if (nsyst .gt. ibarcnt) then
- print*
- print*,'nsyst,ibarcnt:',nsyst,ibarcnt
- print*,'There are more systems than bars.'
- write(15,'(a,2i5)')' nsyst,ibarcnt:',nsyst,ibarcnt
- write(15,'(a)')' There are more systems than bars.'
- call stop1()
- end if
-c
-c Set up dummy forced line & page breaks after last real one
-c
- nflb = nflb+1
- ibarflb(nflb) = ibarcnt+1
- isysflb(nflb) = nsyst+1
- nfpb = nfpb+1
- ipagfpb(nfpb) = npages+1
- isysfpb(nfpb) = nsyst+1
- heightil = ptheight*4./musize
- open(12,status='SCRATCH')
- write(12,'(a)')basenameq(1:lbase)
- write(12,*)lbase
-c
-c Pass to pmxb the initial signature, including effect of transposition.
-c
- write(12,'(6f10.5/f10.5,3i5)')fbar,wheadpt,etait,
- * etatc,etacs1,etatop,etabot,inbothd,inhnoh,isig1
- write(12,*)npages,widthpt,ptheight,hoffpt,voffpt,nsyst
- iflbnow = -1
- isysb4 = 0
- do 8 ifpb = 1 , nfpb
-c
-c Each time thru this loop is like a single score with several pages
-c
- npages = ipagfpb(ifpb)-ipagfpb(ifpb-1)
- nsyst = isysfpb(ifpb)-isysfpb(ifpb-1)
- nomnsystp = (nsyst-1)/npages+1
- nshort = nomnsystp*npages-nsyst
- do 7 ipage = 1 , npages
- nsystp = nomnsystp
- if (ipage .le. nshort) nsystp = nsystp-1
-c
-c Last system number on this page:
- isysendpg = isysb4+nsystp
- nintpg = 0
- do 15 isy = isysb4+1, isysendpg
- if (isysflb(iflbnow+1) .eq. isy) iflbnow = iflbnow+1
- nintpg = nintpg+nistaff(iflbnow)
-15 continue
- xilfrac = 0.
- xiltxt = 0.
- if (ipage.eq.1 .and. ihead.gt.0) then
-c
-c Needn't zero out ihead after printing titles if we only allow titles at top?
-c
- if (iand(ihead,1) .eq. 1) then
- xiltxt = xiltxt+hgtin*4/musize
- xilfrac = xilfrac+etait
- end if
- if (iand(ihead,2) .eq. 2) then
- xiltxt = xiltxt+hgtti*4/musize
- xilfrac = xilfrac+etatc
- end if
- if (iand(ihead,4) .eq. 4) then
- xiltxt = xiltxt+hgtco*4/musize
- xilfrac = xilfrac+etacs1
- else
-c
-c Use double the title-composer space if there is no composer
-c
- xilfrac = xilfrac+etatc
- end if
- end if
- D = xilfrac+nsystp-1+etatop+etabot
-c C = nsystp*(nv-1)
- C = nintpg
-c xN = heightil - xiltxt - 4*nsystp*nv - (nsystp-1)*xilbn
- xN = heightil - xiltxt - 4*(nintpg+nsystp) - (nsystp-1)*xilbn
- if (bottreb) xN = xN-(nsystp-1)*xilbtc
- if (ihead.eq.0 .and. isheadr) xN = xN - xilhdr
- if (ifig .eq. 1) then
- xN = xN - nsystp*xilfig
- end if
- glueil = (xN-b*C)/(D+a*C)
- omegaG = (b*D+a*xN)/(D+a*C)
-c
-c G = \interlines between systems
-c omega*G = \interlines between staves of the same system
-c \interstaff = 4+omega*G
-c C = total number of interstaff spaces in the page
-c D = omega-indep factors for scalable height = nsy-1 (intersystem glue)
-c + etatop + etabot + etatxt +
-c N = scaleable height (\interlignes) = height - htext - staff heights - xil
-c xil = extra interliges = (nsy-1)*xilbn + 10 if header and no titles
-c + (nsy-1)*xiltcb for treble clef bottoms
-c + nsy*xilfig for figures
-c G = N/(D + omega * C) = glueil, (1)
-c But (empirically) omega*G = a*G + b (2)
-c with a=1.071 and b=2.714
-c Solving (1) and (2) gives
-c G = (N-b*C)/(D+a*C) , omega*G = (b*D+a*N)/(D+a*C)
-c Pass to pmxb omega*G (=\interstaff-4)
-c (etatop,bot,it,tc,cx)*G as inputs to \titles
-c
-c glueil = (heightil-xiltxt-nsystp*(xil+4*nv))
-c * /(nsystp*(1+gfact*(nv-1))-1+etatop+etabot+xilfrac)
-c xnsttop = glueil*etatop
-c xintstaff = 4+gfact*glueil
-c
-c Only the first page will get local adjustment now if needed, others in pmxb
-c
- if (ifpb.eq.1 .and. ipage.eq.1 .and. fintstf.gt.0.) then
- facins = fintstf
- fintstf = -1.
- else
-c
-c gintstf = 1.0 by default, but may be changed with AI<x>
-c
- facins = gintstf
- end if
- write(12,*)nsystp,max(0.,etatop*glueil),facins*(omegaG+4)
- ihead = 0
- isheadr = .false.
- isysb4 = isysendpg
-7 continue
-8 continue
-c
-c Done with vertical, now do horizontals
-c
- celsk(1) = elsk(1)
- do 21 ibar = 2 , ibarcnt
- celsk(ibar) = celsk(ibar-1)+elsk(ibar)
-21 continue
- lastbar(0) = 0
- ibar1 = 1
- wmins = -1.
- iflb = 1
- imovbrk = 0
- ikey = 1
-c
-c Return nsyst to its *total* value
-c
- nsyst = isysfpb(nfpb)-1
- do 22 isyst = 1 , nsyst
- if (isyst .eq. isysflb(iflb)) iflb = iflb+1
- if (nmovbrk.gt.0 .and. imovbrk.lt.nmovbrk) then
- if (isyst .eq. isysmb(imovbrk+1)) imovbrk = imovbrk+1
- end if
- ibarb4 = lastbar(isyst-1)
- if (isyst .eq. 1) then
- if (isfirst) elsstarg = celsk(ibarflb(1)-1)/
- * (isysflb(1)-1-fracindent)*(1-fracindent)
- celskb4 = 0.
- else
- celskb4 = celsk(ibarb4)
-c
-c Must dimension isysmb(0:*) just so I can execute this test!
-c
- if (isfirst) then
- if (nmovbrk.gt.0 .and. isyst.eq.isysmb(imovbrk)) then
-c
-c First syst after forced line break. There may be indentation.
-c
- elsstarg = (celsk(ibarflb(iflb)-1)-celskb4)
- * /(isysflb(iflb)-isyst-fracsys(imovbrk))
- * *(1-fracsys(imovbrk))
- else
-c
-c There is no indentation to deal with
-c
- elsstarg = (celsk(ibarflb(iflb)-1)-celskb4)
- * /(isysflb(iflb)-isyst)
- end if
- end if
- end if
- if (isfirst) then
- diff1 = abs(elsstarg-elsk(ibarb4+1))
- do 23 ibar = ibarb4+2 , ibarcnt
- diff = elsstarg-(celsk(ibar)-celskb4)
- if (abs(diff) .ge. diff1) go to 24
- diff1 = abs(diff)
-23 continue
-24 ibar = ibar-1
- lastbar(isyst) = ibar
- nbarss(isyst) = ibar-ibarb4
- else
-c
-c nbarss is given as an input, must compute lastbar and ibar
-c
- lastbar(isyst) = nbarss(isyst)+ibarb4
- ibar = lastbar(isyst)
- end if
-c
-c elss is # of elemskip in the syst. from notes & ars's, not ruleskips, ask's.
-c
- elss(isyst) = celsk(ibar)-celskb4
- write(12,'(i5)')lastbar(isyst-1)+1
-c
-c Transposed sigs are isig1, newkey(2,3,...).
-c
- if (ikey .eq. 1) then
- key1 = isig1
- else
- key1 = newkey(ikey)
- end if
- fsyst = wclef+abs(key1)*wkeysig+2./musize
- xelsk = 0.
-1 if (ikey.lt.nkeys) then
- if (ibrkch(ikey+1).le.lastbar(isyst)) then
-c
-c Add space for all key changes
-c
- ikey = ikey+1
- key2 = newkey(ikey)
- naccs = max(abs(key2-key1),max(abs(key1),abs(key2)))
- fsyst = fsyst+naccs*wkeysig
-c
-c Account for afterruleskips (fbar)
-c
- xelsk = xelsk+fbar/2
- if (ibrkch(ikey).lt.lastbar(isyst) .and. .not.kchmid(ikey))
- * xelsk = xelsk-1.
- key1 = key2
- go to 1
- end if
- end if
-c
-c Add extra fixed space for double bar
-c
- if (isyst .eq. nsyst) then
- fsyst = fsyst+4.5/musize
- end if
-c
-c Add extra fixed space for initial time signature
-c
- if (isyst .eq. 1) then
- fsyst = fsyst+wtimesig
- end if
-c
-c Add extra fixed space for time signature changes & user-defined spaces
-c
- do 26 ibars = ibarb4+1 , lastbar(isyst)
- if (newmb(ibars)) fsyst = fsyst+wtimesig
- fsyst = fsyst+udsp(ibars)/musize
-26 continue
- if (isyst .eq. 1) then
- wdpt = widthpt*(1-fracindent)
- else
- if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and.
- * isyst.eq.isysmb(imovbrk)) then
- wdpt = widthpt*(1-fracsys(imovbrk))
- else
- wdpt = widthpt
- end if
- end if
- wsyspt = wdpt-fsyst*musize-0.4*nbarss(isyst)
-c
-c Checks for min spacing
-c Get min allowable space
-c
- dtmin = 1000.
- do 45 ibar = ibar1 , ibar1+nbarss(isyst)-1
- dtmin = min(dtmin,tnminb(ibar))
- if (wminnh(ibar).ge.0.) wmins = wminnh(ibar)
-45 continue
- if (wmins .lt. 0) wmins = 0.3
- wminpt = (1+wmins)*0.3*musize
-c
-c Find max duration & # of notes for this system
-c
- dtmax = 0.
- nns = 0
- do 43 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1
- dtmax = max(dtmax,durb(iptr))
- nns = nns + nnpd(iptr)
-43 continue
- elmin0 = wsyspt*f1eon(dtmin)/(elss(isyst)+xelsk)
- if (elmin0 .ge. wminpt) then
-c
-c Subtract out fbar stuff to keep old way of passing sumelsk to pmxb;
-c there is no need to "flatten"
-c
- sumelsk = elss(isyst)-fbar*nbarss(isyst)
- eonk = 0.
- ewmxk = 1.
- else
- elmin1 = wsyspt/((fbar*nbarss(isyst)+xelsk)/f1eon(dtmax)+nns)
- if (elmin1 .le. wminpt) then
-c print*
-c print*,'In system #',isyst,' cannot meet min. space rqmt'
-c write(15,'(/a,i5,a)')
-c * 'In system #',isyst,' cannot meet min. space rqmt'
- eonk = 0.9
- else
-c
-c Find eonk by Newton method
-c
- call findeonk(nptr(ibar1),nptr(ibar1+nbarss(isyst))-1,
- * wsyspt/wminpt,fbar*nbarss(isyst)+xelsk,dtmin,dtmax,
- * (wminpt-elmin0)/(elmin1-elmin0))
- eonk = min(.9,eonk)
- end if
- ewmxk = f1eon(dtmax)**eonk
-c
-c Recompute poenom!
-c
- sumelsk = 0
- do 44 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1
- sumelsk = sumelsk
- * + nnpd(iptr)*sqzb(iptr)*feon(durb(iptr)/sqzb(iptr))
-44 continue
- end if
- poenom = wsyspt/(sumelsk+fbar*nbarss(isyst)+xelsk)
-c
-c Set fracindent for output: orig if isyst=1, fracsys(imovbrk) if movbrk, else 0
-c
- if (isyst .gt. 0) then
- if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and.
- * isyst.eq.isysmb(imovbrk)) then
- fracindent = fracsys(imovbrk)
- else
- fracindent = 0.
- end if
- end if
- write(12,'(1pe12.5/i5,5e12.3)') poenom,nbarss(isyst),
- * sumelsk,fsyst,fracindent,eonk,ewmxk
- ibar1 = ibar1+nbarss(isyst)
-22 continue
- rewind(12)
- open(13,status='SCRATCH')
- write(13,'(i5)')ifig
- rewind(13)
- ilbuf = 1
- ipbuf = 0
- if (.not.optimize) then
- write(*,'(/,a)')' Done with first pass'
- print*
- write(15,'(/,a)')' Done with first pass'
- write(15,'()')
- end if
-c
-c Following syntax is needed since pmxa is called with literal argument .false.
-c
- if (isfirst) isfirst = .false.
- return
- end
- subroutine pmxb(inlast,poevec,ncalls,optimize)
-cccccccccccccccccccccccccc
-cc
-cc To Do
-cc
-cc Resolve disagreement in final poe for 1st system, compared with *.mx2
-cc Shift slurs on right- or left-shifted main notes (2/7/99)
-cc Various end-of-input-block repeat problems (ick142.pmx).
-cc Force multiplicity for un-beamed xtups.
-cc Clef change at end of piece
-cc Global "A" option to maximize "X" at a given time tick.
-cc Tighten test for end-of-bar hardspace, flgndv(ivx) due to right-shifted
-cc note. See trubl18.pmx
-cc Tab character as space.
-cc Clef interference with second line of music.
-cc Add space for interferences between *different* lines of music?
-cc Shift arpeggios, both automatic and manual.
-cc Different musicsize for different instruments.
-cc Spacing checks for accid's on left-shifted chord notes
-cc Spacing checks for double dots
-cc Allow forced line breaks w/o setting nsyst.
-cc Cresc-Decresc. (Enhance MusiXTeX first?)
-cc Dynamic Marks.
-cc Bug with Voltas at line end (MusiXTeX problem?).
-cc Subtle bug w/ slur hgt over line brk, see trubl15.pmx
-cc Stem-end slurs.
-cc Allow units in indentation.
-cc Make inline TeX more context sensitive.
-cc Werner's 4/2/98 problem with "o?"
-cc Scor2prt converts e.g. "r0+0" into "r0 0", which seems to be wrong.
-cc converts e.g. "r2db" into "r2d", which might be wrong.
-cc Werner's generalsignature problem with Key change and new transposition.
-cc (wibug8.pmx)
-cc Unequal xtuplets
-cc Print both sets of bar #'s in tex file.
-cc Make barlines invisible \def\xbar{\empty} , fix fbar.
-cc Auto-tie slurs 'At'
-cc Forced line break anywhere (e.g. at a mid-bar repeat).
-cc Clef change at very start of file.
-cc Tighten test for M as macro terminator.
-cc Fix title so not separate limit on author length + composer length.
-cc Arpeggios in xtups.
-cc
-cc mx10b
-cc Option for instrument name at top center. Last item in P command:
-cc P[n]c text is instrument name (use in parts)
-cc P[n]cstuff text is stuff (up to 1st blank)
-cc P[n]c"stuff with spaces" text is stuff with spaces
-cc
-cc Post version 1.43
-cc Reduced space rqmt for multiplicity-0 graces (no flag)
-cc Removed last sepsym in centered whole-bar rests, fixes volta height bug.
-cc
-cc Version 1.43
-cc Fix spacing for end-of-line signature change.
-cc Adjust left-shift of grace group for shifted accidentals.
-cc Put in extra space for left-shifted accidentals.
-cc Fix bug with dot-shift before accid-shift on chord note.
-cc Space-check for right-shifted main notes.
-cc Enable forcing stem direction of single notes in non-beamed xtups.
-cc Disallow clef change after last note before end of input block (pmxa)
-cc Print meter change before page break
-cc increase length of strings for \titles macro
-cc version 1.42
-cc Loosen up input syntax for "X" commands. Subroutine getx()
-cc "B" and "P" in "X" commands
-cc mx09b
-cc Allow multiple rests at start of xtup
-cc Add 64th rest
-cc Fix xtup numbers over rests. (subroutine levrn)
-cc Initialize notcrd=.false. every gulp. Avoids undefined state with e.g.
-cc c za / ( c a ...
-cc Allow double dots to be shifted.
-cc Fix spacing with double dotted notes; permit splitting small note.
-cc Fix \dotted printout so it works with old compiler
-cc mx08b
-cc Automatic spaces if needed for shifted accidentals.
-cc Some Dynamics
-cc Increase accid. horiz. shift resolution to .o5 (use one more bit in nacc)
-cc version 1.41
-cc Allow ":" as last char of path name
-cc Dotted slurs "sb"
-cc Continue bar numbering at movement break "L[integer]Mc"
-cc mx07b
-cc Whole-bar rests with double lines of music. Fixed all options ?
-cc Shift accidentals, either [+|-][integer][+|-][number] or [<|>][number].
-cc Option to suppress centering full-bar rests. "o"
-cc mx06b
-cc Shift accid on left-shifted chord note.
-cc Rest as first note of xtup.
-cc Wrong slopes with small widths. Scale slfac1 by widthpt_default/widthpt
-cc Allow Rb for single bar at movemnet break or end of piece. (islur(25))
-cc Change # of inst at a movement break. noinst is total # and must be used
-cc in 1st movement. ninow is current. nspern(1,...,ninow) is current
-cc staves/inst, nsperi(1,...,noinst) is original. rename tells whether to
-cc reprint names in parindent at a movement break. Default is .false.
-cc unless ninow changes, then .true. But can force either with r+/- as
-cc option in 'M'
-cc mx04b
-cc Double-dotted notes, separate+beamed, main+chord, still no extra space.
-cc ??? Don't shift slur ends on whole notes.
-cc (pmxa) Write line number of error in pmxaerr.dat
-cc mx02b
-cc Admit "RD" before "/" (search for "rptfq2:" )
-cc In doslur, for multi-line staves, single notes, check forced stem dir'n
-cc before setting stemup (used to set horiz offset).
-ccccccccccccccccccccccccccccccc
- parameter (nm=24,nks=125,mv=24576,maxblks=9600)
-c
-c FYI /all/ differs in appearance in function ncmid
-c
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
-ccccccccccccc
-cc islur cc
-ccccccccccccc
-c bit meaning
-c 0 slur activity on this note
-c 1 t-slur here.
-c 2 force 0-slope beam starting on this note
-c 3 Double dotted note!
-c 4 grace before main note
-c 5 left repeat
-c 6 right repeat
-c 7 start Volta
-c 8 doublebar
-c 9 end Volta
-c 10 on=>endvoltabox
-c 11 on=>clefchange
-c 12-14 0=>treble, ... , 6=>bass
-c 15 on=> start new block for clef change (maybe diff. voice)
-c 16 literal TeX string
-c 17 1=up, 0=down stem for single note (override) See bit 30!
-c 18 if on, prohibit beaming
-c 19 if on, full bar rest as pause
-c 20 Beam multiplicity down-up
-c 21 Forced multiplicity for any beam including xtups
-c 22-24 Value of forced multiplicity
-c 25 single barline at movement break
-c 26 doubleBAR (see bits 5,6,8)
-c 27-28 Forced beam fine-tune height (1 to 3)
-c 29 Blank rest
-c 30 If on, get stem dir'n from bit 17
-c 31 If on, suppress printing number with xtuplet starting here
-ccccccccccccc
-cc ipl cc
-ccccccccccccc
-c 0 blank barline (must be iv=1) (would have used islur but no room)
-c 1 look left for K rests, moved here from iornq(30)
-c 2 treblelowoct
-c 3 Open notehead in forced beam xtup
-c 4 Set if single stem tremolo
-c 5-6 termulo multiplicity - 1
-c 7 unused
-c 8 left offset main note one headwidth
-c 9 right offset main note one headwidth
-c 10 chord present?
-c 11-16 Forced beam height adjustment (-30 to +30)
-c 17-22 Forced beam slope adjustment (-30 to +30)
-c 23-26 Slur index for Way-after grace. Inserted when slur is started.
-c 27 5th bit for slur index for Way-after grace (100712)
-c 28 key change: only in voice 1
-c 29 Grace after main note. (Type A)
-c 30 In forced beam. Signals need to check beam heights
-c 31 Grace way after main note. (stretch to next note, type W)
-ccccccccccccc
-cc iornq cc
-ccccccccccccc
-c 0 Ornament "(". Was user-defined horizontal slur shift on this note
-c until 9/24/97; changed that to irest(21)
-c 1-13 stmgx+Tupf._)
-c 14 Down fermata, was F
-c 15 Trill w/o "tr", was U
-c 16-18 Editorial s,f,n
-c 19-20 >^
-c 21 "?" for editorial accid, w/ or w/o s,f,n
-c 22 Set if ihornb governs ornament height. Same in icrdorn.
-c 23 Set in getorn if ANY note at time of this main note has ornament.
-c This is ONLY used in beamstrt to signal whether to do more
-c tests for whether ihornb is needed. (ihornb is only needed
-c if nonchord+upbm, chord+upbm+top_note, chord+dnbm+bot_note)
-c (7/1/00)Also set if any dynamic, as ihornb will be needed when dnbm.
-c 24 Slur on after or way-after grace. Use as signal to START slur.
-c 25 Tweak orn ht. Same in icrdorn for chord note
-c 26 Insert user-defined space before this note (was 22)
-c 27 Arpeggio stop or start (if 2 at same time), or all-in-this-chord
-c 28 caesura or breath
-cc 29 blank barline (must be iv=1) (would have used islur but no room)
-c 29 coda
-cc 30 "Look-left" option for keyboard rest
-c 30 Part-by-part segno oG
-c 31 Set if any note (main or chord) has cautionary accid, for space checks
-ccccccccccccc
-cc irest cc
-ccccccccccccc
-c 0 rest=1, no rest = 0
-c 1 There will be a vertical shift for number of this xtup
-c 2 Set if 2-note tremolo starts here
-c 3-4 nsolid, # of solid beams in 2-note tremolo
-c 5-6 nindent, # of indented beams in 2-note tremolo
-c 7 There is a horizontal shift for xtup number
-c 9-13 Horiz shift, 1=>-1.5, ... , 31=>+1.5
-c 14 Flip up/down-ness of xtup number
-c 15 Single-voice, single note shift X(...)[p]S
-c 16 Start single-voice, multinote shift with this note X(...)[p]:
-c 17 End single-voice, multinote shift after this note. Enter symbol
-c after note. X:
-c 18 User-defined hardspace after last note of bar, *after* this note.
-c Value still stored in udoff(ivx,nudoff(ivx)), not with other
-c hardspaces in udsp, to avoid confusion with time checks.
-c 19 Move the dot. Data stored in ndotmv,updot,rtdot
-c 20 Set if right-shifted main or chord note here. Use for space checks.
-c 21 User-defined hardspace in xtup
-c 22 User-defined slur shift horizontal slur shift.
-c 23 Set on last note before staff-jumping a beam.
-c 24 Set on first note after staff-jumping a beam
-c 25 Suppress rest centering. "ro"
-c 26 Dynamic on this note
-c 27 Set if left-shifted main or chord note here. Use for space checks.
-c 28 Set if xtup starts on this note.
-c 29 Set on lowest-voice note at same time as 1st note after jump-beam.
-c 30 Set on note after end of jump-beam segment, to force new note group
-c 31 Flag for cautionary accidental
-ccccccccccccc
-cc nacc cc
-ccccccccccccc
-c 0-1 0=no accid, 1=fl, 2=sh, 3=na
-c 2 double
-c 3 big
-c 4-9 vertshift-32
-c 10-16 20*(horiz. shift + 5.35) (Recentered ver 2.32)
-c 17 Midi-only accidental
-c 18 2:1 xtup
-c 19 Together with nacc(18), increase multiplicity by 1 and dot 1st note.
-c 20 Set on last note of each seg except last seg of single-slope beam.
-c 21 Set on 1st note of each seg except 1st seg of single-slope beam.
-c 22-26 If .ne.0, printed xtup number for xtup starting on this note.
-c 27 Set for dotted xtup note. Mult dur by 1.5, mult next by .5 & increase
-c multiplicity by 1
-c 28 Set on main note of chord if accidentals are ordered.
-c 29 Tag for chordal accidental shift...means add to autoshifts.
-c 30-31 Set 30|31 if main note in a chord is part of a 2nd and needs to be shifted.
-c If upstem|downstem, main is upper|lower member of 2nd
-c Action is to interchange pitches only when notes are placed.
-ccccccccccccc
-cc mult cc
-ccccccccccccc
-c 0-3 Multiplicity+8 (mult= # of flags)
-c 4 Set if slope adjustment for xtup bracket
-c 5-9 16+slope adjustment
-c 10-15 New stem length, [0-63] => (-4,0,+27.5)
-c 16-22 64+Vertical offset of xtup #
-c 27 Stemlength override
-cc 28-30 New stem length.
-ccccccccccccc
-cc isdat1 cc
-ccccccccccccc
-c 13-17 iv
-c 3-10 ip
-c 11 start/stop switch
-c 12 kv-1
-c 19-25 ichar(code$)
-c 26 force direction?
-c 27 forced dir'n = up if on, set in sslur; also
-c final direction, set in doslur when beam is started, used on term.
-c 28-31 ndxslur, set in doslur when beam is started, used on term.
-ccccccccccccc
-cc isdat2 cc
-ccccccccccccc
-c 0 Chord switch. Not set on main note.
-c 1-2 left/right notehead shift. Set only for chord note.
-c 3 tie positioning
-c 4 dotted slur
-c 6-11 voff1 1-63 => -31...+31
-c 12-18 hoff1 1-127 => -6.3...+6.3
-c 19-25 nolev
-c 26 \sluradjust (p+s)
-c 27 \nosluradjust (p-s)
-c 28 \tieadjust (p+t)
-c 29 \notieadjust (p-t)
-ccccccccccccc
-cc isdat3 cc
-ccccccccccccc
-c 0 set if midslur (at least one argument)
-c 1 set if curve (2 more args)
-c 2-7 32+first arg (height correction) (1st arg may be negative)
-c 8-10 second arg (initial slope)
-c 11-13 third arg (closing slope)
-c 14-21 tie level for use in LineBreakTies
-c 22-29 ncm for use in LineBreakTies
-ccccccccccccc
-cc isdat4 cc Set these all at turn-on using s option
-ccccccccccccc
-c 0-5 Linebreak seg 1 voff 1-63 => -31...+31
-c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3
-c 16-21 Linebreak seg 2 voff 1-63 => -31...+31
-c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3
-ccccccccccccc
-c icrdat c
-ccccccccccccc
-c 0-7 ip within voice
-c 8-11 ivx (together with 28th bit)
-c 12-18 note level
-c 19 accidental?
-c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp)
-c 23 shift left
-c 24 shift right
-c 25 arpeggio start or stop
-c 26 flag for moved dot (here, not icrdot, since this is always reset!)
-c 27 Midi-only accidental
-c 28 (6/27/10) 5th bit for ivx, to allow up to 24 voices
-c 29 Tag for accidental shift...means add to autoshifts.
-c 31 Flag for cautionary accidental on chord note
-ccccccccccccc
-c icrdot c:
-ccccccccccccc
-c 0-6 10*abs(vertical dot shift in \internote) + 64
-c 7-13 10*abs(horizontal dot shift in \internote) + 64
-c 14-19 vert accidental shift-32
-c 20-26 20*(horiz accidental shift+3.2)
-c 27-29 top-down level rank of chord note w/accid. Set in crdaccs.
-c
-c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds.
-c
-cccccccccccccccccccccccccccccccc
- character*131072 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- character*10 figq
- common /comignorenats/ mbrhgt,newmbrhgt,ignorenats
- logical ignorenats,newmbrhgt
- character*1 ulq,sepsymq,sq,chax
- logical beamon,firstgulp,figbass,figchk,
- * isfig,rptnd1,rptprev
- logical loop,lastchar,slint,svolta,evolta,onvolt,
- * cwrest(nm),islast,inlast,optimize
- integer istop(80),numbms(nm),istart(80)
- real*4 xnsttop(75),xintstaff(75),hesk(23),hpts(23),poevec(nks),
- * tstart(80),squez(80)
- character*1 clefq(nm),ulfbq,rptfq1,rptfq2,charq
- character*79 notexq,inameq
- character*40 pathnameq
- character*44 basenameq
- character*24 fmtq
- character*20 voltxtq
- character*120 instrq,titleq,compoq
- common /comlast/ islast,usevshrink
- logical usevshrink,stickyS,OptLineBreakTies,autofbon
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2,multbj1
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /cominbot/ inbothd
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2,ivvfig(2,74)
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- common /comstart/ facmtr
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS,
- * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
- * rptprev,equalize,rptfq1,rptfq2
- common /combeam/ ibmtyp
- common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd,
- * npreslur,was2(nm),ninow,nobar1,nsystp(75),ipage,
- * OptLineBreakTies,HeaderSpecial
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig,
- * lnam(nm),inameq(nm)
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comas2/ nasksys,wasksys(800),elasksys(800)
- common /comas3/ ask(2500),iask,topmods
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,fbon,ornrpt,shifton,isbjmp,notcrd,was2,
- * isbj2,fontslur,WrotePsslurDefaults,HeaderSpecial
- common /comivxudorn/ivxudorn(63)
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- character*128 litq,lnholdq
- logical upslur,bar1syst,vshrink,lrpt,rrpt,lrptpend,
- * ispoi,bcspec,topmods,headlog,clchb,clchv(nm),flgndb,
- * btest,sluron,setis,nobar1
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * maxdotmv(nm),ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /compoi/ ispoi
- common /combc/ bcspec
- common /comeon/ eonk,ewmxk
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /comhsp/ hpttot(176)
- common /combmh/ bmhgt,clefend
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- common /commus/ musize,whead20
- common /comtol/ tol
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- logical mrecord,mplay,endmac,flipend,istype0,lowdot,rename,ispstie
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,equalize,
- * ismbr,putmbr
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /comcb/ nbc,ibcdata(36)
- common /comclefq/ clefq
- common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20),
- * ArpShift(20)
- common /comligfont/ isligfont
- logical isligfont
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /combibarcnt/ ibarcnt
- character*40 nmq
- common /commidisig/ midisig
- common /comclefrests/ centrests
- logical newclef, centrests
- common /comlyr/ inputmlyr
- logical inputmlyr
- common /combottop/ botamt,topamt,bottopgap
- logical bottopgap
- common /comis4bignv/ is4bignv,AIset
- logical is4bignv,AIset
- common /comhair/ idhairuse,idhair(nm)
- common /comc8flag/ c8flag(nm)
- logical c8flag
- common /comshort/ shortfrac,codafrac,ishort,mbrsum,nmbr,nocodabn,
- * poefa
- real*4 poefa(125)
- logical nocodabn
- character*3 shortfraq,rendq
- bottopgap = .false.
- inputmlyr = .false.
- idhairuse = 0
- if (.not.optimize) then
- print*
- print*,'Starting second PMX pass'
- print*
- write(15,'(a)')'Starting second PMX pass'
- end if
- newclef = .false.
- centrests = .false.
- ncalls = ncalls+1
- islast = inlast
- macuse = 0
- isyscnt = 0
- stemmax = 8.2
- stemmin = 3.9
- stemlen = 6.0
- sq = chax(92)
- ignorenats = .false.
- newmbrhgt = .false.
- bcspec = .true.
- topmods = .false.
- ismbr = .false.
- read(12,'(a)')basenameq
- read(12,*)lbase
- read(12,*)fbar,wheadpt,etait,etatc,etacs1,etatop,
- * etabot,inbothd,inhnoh,isig
- ilbuf = 1
- ipbuf = 0
- call getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0,
- * npages,nsyst,musicsize,fracindent,istype0,inameq,
- * clefq,sepsymq,pathnameq,lpath,isig0)
- if (ismidi) then
-c
-c Initial key signature and meter for pickup bar
-c 130313 Unless explicit miditranspose for all parts (to be dealt with later),
-c want concert sig (isig0) here. K+n+m will have changed sig to isig
-c call midievent('k',isig,0)
-c 130316
-c call midievent('k',isig0,0)
-c call midievent('k',midisig,0)
-c
-c Above is probably cosmetic
-c call midievent('k',midisig,0)
- if (xmtrnum0 .gt. tol) then
-c
-c We have a pickup. Some tricky stuff to get a meter:
-c
- xntrial = xmtrnum0
- do 5 ip2 = 0 , 5
- if (abs(mod(xntrial,1.)) .lt. tol) go to 6
- xntrial = xntrial*2
-5 continue
- print*,'Problem finding meter for pickup bar'
- xntrial = 1.
- ip2 = 0
-6 continue
- call midievent('m',nint(xntrial),2**ip2*mtrdenl)
- else
-c
-c No pickup, enter the starting meter
-c
- call midievent('m',mtrnuml,mtrdenl)
- end if
- end if
-c
-c Set musicsize from value passed in common, due to possible reset by S[n]m16
-c
- musicsize = musize
- read(12,*)npages,widthpt,height,hoffpt,voffpt,nsyst,
- * (nsystp(ipa),xnsttop(ipa),xintstaff(ipa),ipa=1,npages),iauto
-c
-c If default width ever changes, must adjust this stmt.
-c
- slfac1 = 0.00569*524./widthpt
- figbass = .false.
- read(13,*)ifig
- if (ifig .eq. 1) then
- figbass = .true.
- open(14,status='SCRATCH')
- write(14,'(a)')sq//'def'//sq//'fixdrop{'//sq//'advance'//sq//
- * 'sysno by 1'//sq//'ifcase'//sq//'sysno%'
- end if
- lastchar = .false.
- ibcoff = 0
- if (xmtrnum0 .gt. 0.) ibcoff = -1
- open(11,status='SCRATCH')
-c
-c vshrink for the first page is calculated in topfile,
-c and if true set interstaff=10. vshrink affects Titles.
-c Must also save vshrink for page ending.
-c
- call topfile(basenameq,lbase,nv,clefq,noinst,musicsize,
- * xintstaff(1),mtrnmp,mtrdnp,vshrink,fbar,fontslur)
-c
-c ninow is working value of # of instruments. noinst is max #, and # at start.
-c
- ninow = noinst
-c
-c Save original printed meter in case movement breaks
-c
- movnmp = mtrnmp
- movdnp = mtrdnp
-c
- if (islast .and. figbass .and. musicsize.eq.16)
- * write(11,'(a)')sq//'def'//sq//'figfont{'//sq//'eightrm}%'
-c
- if (islast .and. isligfont) then
- if (musicsize .eq. 16) then
- write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 8pt%'
- else
- write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 10pt%'
- end if
- end if
- lenbeat = ifnodur(mtrdenl,'x')
- if (mtrdenl .eq. 2) lenbeat = 16
- lenb1 = mtrnuml*lenbeat
- if (mtrdenl .eq. 2) lenb1 = lenb1*2
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- lenb0 = nint(xmtrnum0*lenbeat)
- if (mtrdenl .eq. 2) lenb0 = lenb0*2
- if (lenb0 .ne. 0) then
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno by -1'
- lenbar = lenb0
- else
- lenbar = lenb1
- end if
-c
-c Initialize full-program variables
-c
- fixednew = 0.
- scaldold = 0.
- fintstf = -1.
- gintstf = 1.
- nasksys = 0
- ibarcnt = 0
- iline = 0
- movbrk = 0
- isystpg = 0
- ipage = 1
- iccount = 128
- iask = 0
- nhstot = 0
- nb = 1
- if (.not.optimize) jprntb = 81
- idsig = 0
- iflagbot = 0
-c
-c Next 5 are raise-barno parameters. irzbnd is integer part of default level.
-c
- irzbnd = 3
- if (isig.eq.3 .and. clefq(nv).eq.'t') irzbnd = 4
- is1n1 = 0
- isnx = 0
- SlurCurve = 0.
- ishort = 0
- nocodabn = .false.
- mbrsum = 0
- nmbr = 0
-c
-c 111109 Made global rather than per gulp
-c
- ndyn = 0
- ispoi = .false.
- slint = .false.
- lrptpend = .false.
- rptnd1 = .false.
- rptfq2 = 'E'
- rptprev = .false.
- onvolt = .false.
- flgndb = .false.
- fbon = .false.
- shifton = .false.
- ornrpt = .false.
- setis = .false.
- lowdot = .false.
- rename = .false.
- nobar1 = .false.
- equalize = .false.
- usevshrink = .true.
- WrotePsslurDefaults = .false.
- OptLineBreakTies = .false.
- HeaderSpecial = .false.
-c
-c vshrink is initialized in topfile
-c
- stickyS = .false.
-c
-c ixrest = 1 or 2 if xtup has started with a rest
-c
- do 1 ivx = 1 , nm
- ixrest(ivx) = 0
- fullsize(ivx) = 1.
-c
-c Set legacy note level to middle c as default
-c
- ndlev(ivx,1) = 29
- ndlev(ivx,2) = 29
-1 continue
- npreslur = 0
- nhssys = 0
- listslur = 0
- do 31 i = 1 , 202
- isdat1(i) = 0
- isdat2(i) = 0
-31 continue
- nsdat = 0
-c
-c Initialize flag for figures in any other voice than 1
-c
- ivxfig2 = 0
-c
-c Initialize for loop over gulps
-c
- firstgulp = .true.
-c
-c Start a gulp
-c
-30 loop = .true.
- notcrd = .true.
- isbjmp = .false.
- isbj2 = .false.
- autofbon = .false.
- tautofb = 0.
- nbars = 0
- nfigs(1) = 0
- nfigs(2) = 0
- ngrace = 0
- ntrill = 0
- ncrd = 0
- nudorn = 0
- nlit = 0
- nvolt = 0
- ibarmbr = 0
- nudsp = 0
-c ndyn = 0 ! 111109
- ntxtdyn = 0
- nbc = 0
- NumArpShift = 0
- do 3 i = 1 , 37
- graspace(i) = 0.
-3 continue
-c
-c Now initialize up to nv. Do it in getnote as r'qd for 2nd voices per syst.
-c and also if nv increases in an 'M' directive.
-c
- do 4 iv = 1 , nv
- call newvoice(iv,clefq(iv),.false.)
-4 continue
-c
-c Check if endsymbol was set earlier
-c
- if (rptnd1) then
- rptnd1 = .false.
- rptfq2 = rptfq1
- else
-c
-c Only use if movbrk>0, to signal default ('RD')
-c
- rptfq2 = 'E'
- end if
- iv = 1
- ivx = 1
-2 if (loop) then
-c
-c Within this loop, nv voices are filled up for the duration of the block.
-c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
-c nolev(nv,nnl(nv)),nodur(..),accq(..),irest(..).
-c nbars is for this input block.
-c Only at the beginning of an input block will there be a possible mtr change,
-c signalled by a nonzero mtrnuml. (which will be re-zeroed right after change)
-c
- call getnote(loop)
- if (lastchar) go to 40
- go to 2
- end if
-c
-c Finished an input block (gulp).
-c
- if (ismidi) then
-c
-c Put rests into midi array for 2nd lines that were not used in this gulp.
-c
- do 60 iv = 1 , nv
- if (twoline(iv) .and. nvmx(iv).eq.1) then
- if (firstgulp .and. lenb0.ne.0) then
- call addmidi(midchan(iv,2),0,0,0,
- * (nbars-1.)*lenbar+lenb0,.true.,.false.)
- else
- call addmidi(midchan(iv,2),0,0,0,1.*nbars*lenbar,.true.,
- * .false.)
- end if
- end if
-60 continue
- end if
- nvolt = 0
- do 28 iv = 1 , nm
- nudoff(iv) = 0
- maxdotmv(iv) = ndotmv(iv)
- ndotmv(iv) = 0
-28 continue
-c
-c Put stuff at top of p.1. Must wait until now to have read title info.
-c
- if (ibarcnt .eq. 0) then
- call puttitle(inhnoh,xnsttop(ipage),
- * etatop,sq,etait,etatc,etacs1,nv,vshrink,sepsymq)
- if (HeaderSpecial)
-c
-c Write special header for first page
-c
- * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%'
- end if
- do 10 ibar = 1 , nbars
- ibarcnt = ibarcnt+1
- bar1syst = ibarcnt .eq. iauto
- ndig = max(0,int(log10(.001+ibarcnt+ibcoff)))
- if (islast)
- * write(11,'(a11,i'//chax(50+ndig)//')')
- * '% Bar count',ibarcnt+ibcoff
- if (ibar .ne. ibarmbr) then
- if (.not.optimize) call outbar(ibarcnt+ibcoff,jprntb)
- else
- if (.not.optimize) then
- write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1
- write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1
- jprntb = 0
- end if
- ibcoff = ibcoff+mbrest-1
-c if (ibar.eq.1 .and. firstgulp .and.
-c * .not.btest(islur(1,1),5)) xb4mbr = facmtr*musicsize
- if (ibar.eq.1 .and. firstgulp .and.
- * .not.btest(islur(1,1),5)) xb4mbr = -.2*musicsize
- end if
-c
-c Move the read to after end-of-bar hardspace checks, so we get right poenom
-c at end of a line.
-c if (bar1syst) read(12,*) poenom
-c
-c Check for clef at start of bar. No slide yet. Also flags at end of prev.
-c bar. This block is run at the start of every bar. May fail for flag at
-c end of last bar. To account for necc. hardspaces, compute and store
-c nhssys = # of hard spaces for this system
-c hesk(nhssys) = elemskips avialable
-c hpts(nhssys) = hard points needed, including notehead
-c Here, merely insert placeholder into output. Later, when poe is computed,
-c compute additional pts and store them in hpttot(1...nhstot). Finally in
-c subroutine askfig, write true pts where placeholders are.
-c
- ioff = 0
- if (ibar .gt. 1) ioff = nib(1,ibar-1)
- clchb = btest(islur(1,ioff+1),15)
- putmbr = .false.
- if (ismbr) then
- if (clchb) then
-ccc
-ccc Clef change and multi-bar rest coming up. Kluge to get space at end of rest.
-ccc
- write(11,'(a)')sq//'let'//sq//'mbrt'//sq//'mbrest'
- * //sq//'def'//sq//'mbrest#1#2#3{%'
- write(11,'(a14,f4.1,a)')sq//'mbrt{#1}{#2}{',musicsize*.55,
- * '}'//sq//'global'//sq//'let'//sq//'mbrest'//sq//'mbrt}%'
-cc
-cc RDT suggestion is inset blank barline - 160103 Abandoned
-cc
-c write(11,'(a)')sq//'setemptybar'//sq//'bar'//sq//'qspace'
-c * //sq//'advance'//sq//'barno-1'
- end if
- ismbr = .false.
- putmbr = .true.
- end if
- if (ibar .eq. ibarmbr) ismbr = .true.
-c
-c Set flag here so at start of next bar, if there's a clef change, can add space
-c after the mbr with the above kluge
-c
- if (.not.(clchb .or. flgndb)) go to 23
-c
-c Must check available space
-c
- ptsndb = 0.
-c
-c Zero out block signal
-c
- if (clchb) islur(1,ioff+1) = ibclr(islur(1,ioff+1),15)
-c
-c In this loop, we determine how much hardspace is needed (if any)
-c 9/7/97 Note that for last bar in input block, if number of lines of
-c music decreases in new block, highest numbered ones won't be checked
-c since the loop below covers the new nvmx(iv), not necessarily the old
-c one.
-c 4/18/98 Apparently nmxsav was a solution to the above problem
-c
- do 16 iv = 1 , nv
- do 16 kv = 1 , nvmxsav(iv)
- ivx = ivmxsav(iv,kv)
- ptsndv = flgndv(ivx)*wheadpt
- ioff = 0
- if (ibar .gt. 1) then
- ioff = nib(ivx,ibar-1)
- ip = ioff
- if (ibar.gt.2) ip = ioff-nib(ivx,ibar-2)
-c prevtn(ivx) = tnote(iand(ipl(ivx,ip),255))
- prevtn(ivx) = tnote(ipl2(ivx,ip))
-c
-c If ibar=1 (1st bar in input block), prevtn(ivx) was set at end of makeabar.
-c
- end if
-c
-c Only allow clef changes when ivx <= nv
-c
- if (ivx .le. nv) then
- clchv(iv) = clchb .and. btest(islur(iv,ioff+1),11)
- if (clchv(iv)) then
-c
-c Clef change in this voice. Turn off signal. Get space avail.
-c
- islur(iv,ioff+1) = ibclr(islur(iv,ioff+1),11)
- if (abs(prevtn(iv)-space(nb)).lt.tol) ptsndv =
- * ptsndv+clefend*wheadpt
- end if
- end if
- ptsndb = max(ptsndb,ptsndv+wheadpt*xspfac)
-16 continue
-c
-c ???? where is nb set??? nb probably in left over from makeabar
-c
- esk = feon(space(nb)*squez(nb))
- ptsdflt = esk*poenom-wheadpt
-c if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0) then
- if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0
- * .and. .not.putmbr) then
-c
-c Must ADD hardspace! So put in a placeholder, and store params for later.
-c
- if (islast) write(11,'(a)')sq//'xardspace{ pt}%'
- nhssys = nhssys+1
- if (ptsndb-ptsdflt .gt. ptsgnd-poenom*eskgnd) then
- hesk(nhssys) = esk
- hpts(nhssys) = ptsndb+wheadpt
- else
- hesk(nhssys) = eskgnd
- hpts(nhssys) = ptsgnd+wheadpt
- end if
- fixednew = fixednew+hpts(nhssys)
- scaldold = scaldold+hesk(nhssys)
- end if
- if (clchb) then
- do 17 iv = 1 , nv
- if (clchv(iv)) then
- notexq = sq//'znotes'
- lnote = 7
- do 24 iiv = 2 , iv
- notexq = notexq(1:lnote)//sepsymq(iiv-1)
- lnote = lnote+1
-24 continue
-c
-c Recompute ioff since it will vary from voice to voice
-c
- if (ibar .eq. 1) then
- ioff = 0
- else
- ioff = nib(iv,ibar-1)
- end if
-c
-c Must call clefsym to get nclef, even if there is a movement break
-c
- call clefsym(islur(iv,ioff+1),fmtq,lclef,nclef)
-c
-c If clefq = '8', must change '0' in pos'n 9 to '8'
-c
- if (btest(ipl(iv,ioff+1),2)) fmtq =
- * fmtq(1:8)//'8'//fmtq(10:10)
- if (movbrk.eq.0 .and.
- * islast)
- * write(11,'(a)')notexq(1:lnote)//fmtq(1:lclef)//sq//'en%'
- call wsclef(iv,ninow,nclef)
-c
-c Set new flag to be used just outside this loop, to kluge
-c any calls to \CenterBar for full-bar rests, to make room for clef.
-c
- newclef = .true.
-c
-c 151220
-c wrong test:
-c If clefq = '8', must add eg \settrebleclefsymbol3\treblelowoct%
-c Replaced with right one. But also, clefq(iv) seems to stay at 8 here,
-c and if we change from TLO to normal clef, need to resetclefsymbols
-c
-c if (clefq(iv) .eq. '8') then
- if (btest(ipl(iv,ioff+1),2)) then
-c
-c Find instrument number for voice iv
-c
- iv1 = 1
- do 1111 iinst = 1 , ninow
- if (iv .lt. iv1+nspern(iinst)) go to 2222
- iv1 = iv1+nspern(iinst)
-1111 continue
- print*
- print*,'Should not be here in pmxb!'
- call stop1()
-2222 continue
- if (iinst .le. 9) then
- write(11,'(a20,i1,a)')sq//'settrebleclefsymbol',iinst,
- * sq//'treblelowoct%'
- else
- write(11,'(a20,i2,a)')sq//'settrebleclefsymbol',iinst,
- * sq//'treblelowoct%'
- end if
- c8flag(iv) = .true.
- else
- if (clefq(iv) .eq. '8') then
- write(11,'(a20)')sq//'resetclefsymbols'
- end if
- end if
- end if
-17 continue
- if (islast) write(11,'(a)')sq//'pmxnewclefs'
- end if
-23 continue
-c
-c Kluge \CenterBar for whole bar rests if necessary
-c
- if (newclef .and. centrests) then
-c write(11,'(a)')sq//'def'//sq//'value{11}%'
- nvalue = nint(.55*musicsize)
- if (nvalue .gt. 10) then
- write(11,'(a11,i2,a2)')
- * sq//'def'//sq//'value{',nvalue,'}%'
- else
- write(11,'(a11,i1,a2)')
- * sq//'def'//sq//'value{',nvalue,'}%'
- end if
- end if
- newclef = .false.
- centrests = .false.
-c
-c End of loop for end-of-bar hardspaces and non-movbrk clef symbol.
-c
- if (bar1syst) then
- read(12,*) poenom
- end if
-c
-c Repeat symbols. Haven't slid down yet, so use islur(1,nib(1,ibar-1)+1)
-c
- if (ibar .eq. 1) then
- islnow = islur(1,1)
-c iornqnow = iornq(1,1)
- iplnow = ipl(1,1)
- else
- islnow = islur(1,nib(1,ibar-1)+1)
-c iornqnow = iornq(1,nib(1,ibar-1)+1)
- iplnow = ipl(1,nib(1,ibar-1)+1)
- end if
-c
-c Check for R-symbols set at end of prior input block
-c
- if (movbrk.eq.0 .and. rptfq2.ne.'E') then
- if (rptfq2 .eq. 'D') then
- islnow = ibset(islnow,26)
- else if (rptfq2 .eq. 'r') then
- islnow = ibset(islnow,6)
- else if (rptfq2 .eq. 'd') then
- islnow = ibset(islnow,8)
- else if (rptfq2 .eq. 'b') then
- islnow = ibset(islnow,25)
- else
- print*
- print*,'Illegal symbol with "R" at end of input block:',
- * rptfq2
- call stop1()
- end if
- rptfq2 = 'E'
- end if
- if (iand(islnow,352) .ne. 0) then
-c
-c Bit 5(lrpt), 6(rrpt), or 8(doublebar) has been set
-c
- lrpt = btest(islnow,5)
- rrpt = btest(islnow,6)
- lrptpend = lrpt.and.bar1syst
- if (lrpt .and. .not.lrptpend) then
- if (rrpt) then
- if (islast) write(11,'(a)')sq//'setleftrightrepeat'
- fixednew = fixednew+wheadpt*lrrptfac-0.4
- else
- if (islast) write(11,'(a)')sq//'setleftrepeat'
- fixednew = fixednew+wheadpt*rptfac-0.4
- end if
- else if (rrpt) then
- if (islast) write(11,'(a)')sq//'setrightrepeat'
- fixednew = fixednew+wheadpt*rptfac-0.4
- else if (btest(islnow,8)) then
- if (islast) write(11,'(a)')sq//'setdoublebar'
- fixednew = fixednew+wheadpt*dbarfac-0.4
- end if
- else if (btest(islnow,26)) then
-c
-c doubleBAR
-c
- if (islast) write(11,'(a)')sq//'setdoubleBAR'
- fixednew = fixednew+wheadpt*ddbarfac-0.4
-c else if (btest(iornqnow,29)) then
- else if (btest(iplnow,0)) then
-c
-c no bar line
-c
-c-- if (islast) write(11,'(a)')sq//'setzalaligne'
-c++
- if (islast) then
- if (movbrk .eq. 0) then
- write(11,'(a)')sq//'setzalaligne'
- else
-c
-c Encountered "Rz" at start of input block at start of new movement, Must
-c use newmovement macro with arg 4 rather than setzalaligne, since former
-c already redefines stoppiece.
-c
- rptfq2 = 'z'
- end if
- end if
-c++
- fixednew = fixednew-0.4
- end if
-c
-c 1st and 2nd endings
-c
- svolta = btest(islnow,7)
- evolta = btest(islnow,9)
- if (evolta) then
- if (btest(islnow,10)) then
- if (islast) write(11,'(a)')sq//'endvoltabox'
- else
- if (islast) write(11,'(a)')sq//'endvolta'
- end if
- onvolt = .false.
- end if
- if (svolta) then
- nvolt = nvolt+1
- lvoltxt = index(voltxtq(nvolt),' ')-1
- if (lvoltxt .eq. 1) then
- if (islast) write(11,'(a)')sq//'Setvolta'
- * //voltxtq(nvolt)(1:1)//'%'
- else
- if (islast) write(11,'(a)')sq//'Setvolta'//'{'//
- * voltxtq(nvolt)(1:lvoltxt)//'}%'
- end if
- onvolt = .true.
- end if
- if (ibar .gt. 1) then
- ipnow = nib(1,ibar-1)+1
- else
- ipnow = 1
- end if
- iplnow = ipl(1,ipnow)
- if (bar1syst) then
-c
-c If listslur>0, then there is at least one slur or tie carried over the break
-c
- ispstie = .false.
- if (OptLineBreakTies .and. .not.fontslur .and. listslur.ne.0
- * .and. islast)
- * call LineBreakTies(isdat1,isdat2,isdat3,isdat4, nsdat,
- * ispstie,sepsymq)
- iline = iline+1
-c
-c End an old system, Start a new system
-c
-c Reduce space before mbrest at start of system
-c Need this even if no accidentals in key signature
-c
- if (ibar.eq.ibarmbr) xb4mbr = -.2*musicsize
-c
- if (iline .ne. 1) then
-c
-c Not first line.
-c Get corrected poe = points/elemskip for *previous* system
-c
- wdpt = widthpt*(1-fracindent)
- poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/
- * (elsktot+fbar*nbarss-scaldold)
- isyscnt = isyscnt+1
- poevec(isyscnt) = poe
-c
-c Transfer data for system into global arrays to hold until very end
-c
- do 9 ia = 1 , nasksys
- iask = iask+1
- ask(iask) = (wasksys(ia)/poe-abs(elasksys(ia)))
- * /poefa(iline-1)
-c
-c Only admit negative ask if it was user-defined space, signalled by elask<=0.
-c
- if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.)
-9 continue
- do 25 ia = 1 , nhssys
- nhstot = nhstot+1
- hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.)
-25 continue
-c
-c Reset counters for new system
-c
- scaldold = 0.
- fixednew = 0.
- nasksys = 0
- nhssys = 0
- end if
-c
-c End of if block for first bar of non-first system. Still 1st bar, any system
-c
- if (islast.and.figbass) write(11,'(a)')sq//'fixdrop%'
- isystpg = isystpg+1
-c
-c Try moving the next stmt way down, to fix a bug and get \eject printed at
-c end of single-system page.
-c if (isystpg .eq. nsystp(ipage)) isystpg = 0
- read(12,*)nbarss,elsktot,fsyst,frac,eonk,ewmxk
- if (iline .gt. 1) fracindent=frac
- if (figbass) then
- ifigdr(1,iline) = 4
- ifigdr(2,iline) = 4
- end if
- slfac = slfac1*musicsize*elsktot
- if (iline .ne. 1) then
-c
-c For the line just _finished_, put figdrop in separate file.
-c
- if (figbass) write(14,'(a9,i2,a10,i2,1x,a4)')
- * sq//'figdrop=',ifigdr(1,iline-1),
- * ' '//sq//'figdtwo=',ifigdr(2,iline-1),sq//'or%'
-c
-c Check slurs in top staff for interference w/ barno. Only check when
-c # if digits in barno >= |isig| But to keep on/off phasing, must ALWAYS
-c keep track of ons and offs when |isig|<=3.
-c
- ndigbn = int(alog10(ibarcnt+ibcoff+.01))+1
- isnx = 0
- if (ndigbn.ge.iabs(isig) .and. is1n1.gt.0) then
-c
-c There's a slur in top voice over the line break, hgt=is1n1, idcode=is2n1
-c Look for termination in remainder of this input block. If not found,
-c just use is1n1. Remember, haven't slid down yet.
-c
- ioff = 0
- if (ibar .gt. 1) ioff = nib(ivmx(nv,nvmx(nv)),ibar-1)
- do 50 isdat = 1 , nsdat
- if (igetbits(isdat1(isdat),5,13).eq.ivmx(nv,nvmx(nv))
- * .and. .not.btest(isdat1(isdat),11)
- * .and. igetbits(isdat1(isdat),7,19).eq.is2n1) then
-c
-c Found slur ending. Just check note height, can't do fine adjustments.
-c
-c is1n1 = max(is1n1,igetbits(isdat2(nsdat),7,19))
- is1n1 = max(is1n1,igetbits(isdat2(isdat),7,19))
- go to 51
- end if
-50 continue
-c
-c If exiting loop normally, did not find end of slur. c'est la vie.
-c
-51 continue
- isnx = idim(is1n1,ncmid(nv,1)+1+irzbnd)
- if (isnx .gt. 0) then
-c
-c AHA! Slur likely to interfere with barno.
-c
-c Modified 090525 to use \bnrs
-c
- slint = .true.
- fmtq = '(a16,i1,a14)'
- if (irzbnd+isnx .gt. 9) fmtq = '(a16,i2,a14)'
- if (islast) write(11,fmtq)sq//'def'//sq//'raisebarno{',
- * irzbnd+isnx,'.5'//sq//'internote}%'
-c if (islast) then
-c if (isnx .le. 9) then
-c write(11,'(a5,i1,a2)')sq//'bnrs',isnx,'0%'
-c else
-c write(11,'(a6,i2,a3)')sq//'bnrs{',isnx,'}0%'
-c end if
-c end if
-c
- end if
- end if
- if (movbrk .gt. 0) then
-c
-c movbrk = 0
-c Move the reset down, so can use movbrk>0 to stop extra meter prints.
-c
-c New movement. Redefine stoppiece, contpiece. These will be called either
-c explicitly or as part of alaligne.
-c indsym = 0,1,2 for doubleBAR , doublebar, rightrepeat.
-c This is passed to \newmovement.
-c
- if (rptfq2 .eq. 'E') rptfq2 = 'D'
- indsym = index('Ddrbz',rptfq2)-1
- rptfq2 = 'E'
-c
-c Also check for Rd or Rr set the normal way
-c
- if (btest(islnow,8)) then
- indsym = 1
- else if (btest(islnow,6)) then
- indsym = 2
- end if
- if (indsym .lt. 0) then
- print*
- print*,'Illegal end symbol before "/"'
- call stop1()
- end if
-c
-c Check for continuation (no bar number reset)
-c
- if (islast.and.nobar1) then
- write(11,'(a)')sq//'advance'//sq//'barno1'
- * //sq//'global'//sq//'startbarno'//sq//'barno%'
-c
-c Need above for shortening case mcm with Mc
-c
- end if
-c
-c Per Rainer's suggestion, changing \nbinstruments via 3rd arg of \newmovement
-c
-c if (movgap .lt. 10) then
-c if (islast) write(11,'(a12,2i1,a1)')
-c * sq//'newmovement',movgap,indsym,'%'
-c else
-c if (islast) write(11,'(a13,i2,a1,i1,a1)')
-c * sq//'newmovement{',movgap,'}',indsym,'%'
-c end if
- if (islast) then
- nmq = sq//'newmovement'
- lnmq = 12
- if (movgap .lt. 10) then
- lnmq = 14
- write(nmq(13:14),'(2i1)')movgap,indsym
- else
- lnmq = 17
- write(nmq(13:17),'(a1,i2,a1,i1)')'{',movgap,'}',indsym
- end if
- if (ninow .lt. 10) then
- lnmq = lnmq+1
- write(nmq(lnmq:lnmq),'(i1)')ninow
- else
- lnmq = lnmq+4
- write(nmq(lnmq-3:lnmq),'(a1,i2,a1)')'{',ninow,'}'
- end if
- lnmq = lnmq+1
- write(nmq(lnmq:lnmq),'(a1)')'%'
- if (ishort .eq. 4) then
-c
-c Ending Short-blank-coda
-c
- write(11,'(a)')sq//'Endpiece}}%'
- end if
- write(11,'(a)')nmq(1:lnmq)
- if (ishort .eq. 2) then
- write(11,'(a)')sq//'stoppiece}}%'
- ishort = 5
- else if (ishort .eq. 4) then
- write(11,'(a)')sq//'let'//sq//'stoppiece'//sq//
- * 'holdstop%'
-c
-c Since we bypass newmovement, need to set the vertical gap.
-c
- if (movgap .gt. 10) then
- write(11,'(a6,i2,a11)')
- * sq//'vskip',movgap,sq//'internote%'
- else if (movgap .gt. 0) then
- write(11,'(a6,i1,a11)')
- * sq//'vskip',movgap,sq//'internote%'
- end if
- ishort = 6
- end if
- if ((ishort.eq.5.or.ishort.eq.6).and..not.rename) then
- do 62 iinst = 1 , ninow
- if (islast) then
- if (iinst .lt. 10) then
- write(11,'(a8,i1,a3)')sq//'setname',iinst,'{}%'
- else
- write(11,'(a9,i2,a4)')sq//'setname{',iinst,
- * '}{}%'
- end if
- end if
-62 continue
- end if
- rename = .false.
- end if
-c
-c Change generalmeter if necessary
-c
- if (islast) then
- call wgmeter(mtrnmp,mtrdnp)
- end if
- mtrnuml = 0
-c
-c (Moved all name-writing to getnote, right when 'M' is detected)
-c
- if (btest(iplnow,28)) then
-c
-c Key signature at movement break
-c
- iplnow = ibclr(iplnow,28)
- if (isig .gt. 0) then
- if (islast) write(11,'(a18,i1,a2)')
- * sq//'generalsignature{',isig,'}%'
- else
- if (islast) write(11,'(a18,i2,a2)')
- * sq//'generalsignature{',isig,'}%'
- end if
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- end if
- if (parmov .ge. -.1) then
-c
-c Resent paragraph indentation
-c
- ipi = parmov*widthpt+.1
- if (ipi .lt. 10) then
- if (islast) write(11,'(a11,i1,a2)')
- * sq//'parindent ',ipi,'pt'
- else if (ipi .lt. 100) then
- if (islast)
- * write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt'
- else
- if (islast)
- * write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt'
- end if
- end if
- if (ishort .eq. 6) then
- if (iflagbot .eq. 1) then
- write(11,'(a)')sq//'vfill'//sq//'eject'
-c iflagbot = 0
-c ishort = 0
- else
- write(11,'(a)')sq//'contpiece'
- end if
-c
-c Zero ishort later trying to write alaligne
-c
- end if
- end if ! End of movement break stuff
- if (isystpg .eq. 1) then
-c
-c First line on a page (not 1st page, still first bar). Tidy up old page
-c then eject.
-c
-c Removed this 5/13/01 as it was causing double endvoltas. This probably
-c is only needed at the end in case there is no endvolta specified.
-c if (onvolt) then
-cc if (islast) write(11,'(a)')sq//'endvoltabox%'
-cc onvolt = .false.
-c end if
-c
-c
-c Check for meter change at start of a new PAGE
-c
- if (mtrnuml .gt. 0) then
-c
-c Meter change at start of a new page. Ugly repeated coding here.
-c
- mtrnms = mtrnuml
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- mtrnuml = mtrnms
- if (movbrk .eq. 0 .and. islast) then
- call wgmeter(mtrnmp,mtrdnp)
- end if
- end if
-c
-c Key signature change?
-c
- if (btest(iplnow,28) .and. movbrk.eq.0) then
- notexq = sq//'xbar'//sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'generalsignature{'
- lnote = 49
- if (isig .lt. 0) then
- notexq = notexq(1:49)//'-'
- lnote = 50
- end if
- if (islast) write(11,'(a)')
- * notexq(1:lnote)//chax(48+abs(isig))//'}%'
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- if (islast .and. ignorenats)
- * write(11,'(a)')sq//'ignorenats%'
- if (islast) write(11,'(a)')sq//'zchangecontext'//sq
- * //'addspace{-'//sq//'afterruleskip}'
- * //sq//'zstoppiece'//sq//'PMXbarnotrue%'
- else if (mtrnuml.gt.0 .and. movbrk.eq.0) then
-c
-c Meter change but no signature change
-c
- if (islast)
- * write(11,'(a)')sq//'xchangecontext'//sq//'addspace{-'//
- * sq//'afterruleskip}'//sq//'let'//sq//'bnat'//sq//
- * 'barnoadd%'
- if (islast)
- * write(11,'(a)')sq//'def'//sq//'barnoadd{'//sq//'let'//
- * sq//'barnoadd'//sq//'bnat}'//sq//'zstoppiece%'
- else
- if (islast) then
- if ((ishort.eq.4.or.ishort.eq.2)
- * .and. iflagbot.eq.1) then
- ntmp = ibarcnt-ibarcnt0-nmbr+mbrsum
- if (ntmp .le. 9) then
- shortfraq(1:1) = char(48+ntmp)
- lntmp = 1
- else
- write(shortfraq(1:2),'(i2)')ntmp
- lntmp = 2
- end if
- write(11,'(a)')sq//'endpiece}}'//sq//'advance'//sq
- * //'barno'//shortfraq(1:lntmp)
-c
-c Move down so can insert fil at begin
-c iflagbot = 0
-c ishort = 0
-c
- else if ((ishort.ne.6.and.ishort.ne.2) .or.
- * iflagbot.ne.1) then
- write(11,'(a)')sq//'stoppiece%'
- end if
- end if
- end if
-c
-c This is the key spot when vshrink is used. Value of vshrink here comes from
-c just after the prior pagebreak, i.e., it is not affected by "Av"
-c that may have been entered at this pagebreak, since that only affects usevshrink.
-c So choose page *ending* (with or without \vfill) depending on old vshrink. Then
-c check value of usevshrink to reset vshrink if necessary for the new page, where
-c we have to set \interstaff and later call puttitle.
-c Top of first page needs special treatment. For this we use
-c novshrinktop, which was set in g1etnote on the first pass, since on
-c second pass, vshrink at top of page one is dealt with in topfile, which is called
-c *before* any reading in any "Av" at the top of the first input block.
-c
- if (.not.vshrink) then
- if (islast .and. bottopgap) then
- if (abs(botamt) .gt. 1.e-6) then
- if (botamt .gt. 9.95) then
- fmtq = '(a,f4.1,a)'
- else if (botamt .gt. 0.) then
- fmtq = '(a,f3.1,a)'
- else if (botamt .gt. -9.95) then
- fmtq = '(a,f4.1,a)'
- else
- fmtq = '(a,f5.1,a)'
- end if
- write(11,fmtq)sq//'null'//sq//'vskip',botamt,
- * sq//'Internote%'
- end if
- end if
- xnstbot = xnsttop(ipage)*etabot/etatop
- if (xnstbot .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else
- fmtq = '(a,f4.1,a)'
- end if
- if (islast) write(11,fmtq)sq//'vskip',xnstbot,
- * sq//'Interligne'//sq//'eject%'
- if (islast .and. bottopgap) then
- if (abs(topamt) .gt. 1.e-6) then
- if (topamt .gt. 9.95) then
- fmtq = '(a,f4.1,a)'
- else if (topamt .gt. 0.) then
- fmtq = '(a,f3.1,a)'
- else if (topamt .gt. -9.95) then
- fmtq = '(a,f4.1,a)'
- else
- fmtq = '(a,f5.1,a)'
- end if
- write(11,fmtq)sq//'null'//sq//'vskip',topamt,
- * sq//'Internote%'
- end if
- bottopgap = .false.
- end if
- else
- if (islast) then
- if (iflagbot.eq.1.and.ishort.eq.6)then
-c
-c cleanup for case bcm only
-c
- iflagbot = 0
- ishort = 0
- else
- write(11,'(a)') sq//'vfill'//sq//'eject%'
- if (iflagbot.eq.1.and.ishort.eq.2) then
-c Clean up case bsl only
- write(11,'(a)')sq//'makeatletter'//sq//'fil at begin'
- * //sq//'makeatother'
- iflagbot = 0
- ishort = 0
- end if
- end if
- end if
- end if
- ipage = ipage+1
-c
-c Now that page is ejected, compute new vshrink
-c
- vshrink = xintstaff(ipage).gt.20 .and. usevshrink
- if (vshrink) then
- xinsnow = 10
- else
- xinsnow = xintstaff(ipage)
- end if
- if (fintstf.gt.0 .and. ipage.gt.1) then
- xinsnow = xinsnow*fintstf/gintstf
- fintstf = -1.
- end if
- if (xinsnow .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else if (xinsnow .lt. 99.95) then
- fmtq = '(a,f4.1,a)'
- else
- fmtq = '(a,f5.1,a)'
- end if
-c
-c Vertical spacing parameters, then restart
-c
- if (is4bignv) xinsnow = .95*xinsnow
- if (islast) then
- write(11,fmtq)sq//'interstaff{',xinsnow,
- * '}'//sq//'contpiece'
- end if
-c
-c Check for meter change at start of a new PAGE
-c
- if (mtrnuml .gt. 0) then
-c
-c Meter change at start of a new page
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (movbrk .eq. 0) then
- if (islast) then
- call wgmeter(mtrnmp,mtrdnp)
- end if
- if (mtrdnp .gt. 0) then
- if (islast) write(11,'(a)')sq//'newtimes2%'
- if (ibar .eq. ibarmbr) xb4mbr = -.2*musicsize
- end if
- end if
- end if
-c
-c If no real titles here, which there probably will never be, make vertical
-c space at page top with \titles{...}. headlog=.false.<=>no real titles
-c
- if (ishort.eq.4 .and. iflagbot.eq.1) then
- ishort = 0
- iflagbot = 0
- write(11,'(a)')sq//'makeatletter'//sq//'fil at begin'//sq//
- * 'makeatother'
- end if
- call puttitle(inhnoh,xnsttop(ipage),etatop,
- * sq,etait,etatc,etacs1,nv,vshrink,sepsymq)
- if (HeaderSpecial)
-c
-c Write special header for first page
-c
- * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%'
- else
-c
-c First bar of system, not a new page, force line break
-c
- if (btest(iplnow,28)) then
-c
-c Signature change
-c
- notexq = sq//'xbar'//sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'generalsignature{'
- lnote = 49
- if (isig .lt. 0) then
- notexq = notexq(1:49)//'-'
- lnote = 50
- end if
- if (islast) write(11,'(a)')notexq(1:lnote)
- * //chax(48+abs(isig))//'}%'
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%'
- if (mtrnuml .ne. 0) then
-c
-c Meter+sig change, new line, may need mods if movement break here.
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (islast) then
- call wgmeter(mtrnmp,mtrdnp)
- if (ignorenats) write(11,'(a)')sq//'ignorenats%'
- write(11,'(a)')sq//'xchangecontext'//sq//
- * 'addspace{-'//sq//'afterruleskip}'
- * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%'
- write(11,'(a)')sq//'addspace{-'//sq
- * //'afterruleskip}%'
- call wgmeter(mtrnmp,mtrdnp)
- if (ignorenats) write(11,'(a)')sq//'ignorenats%'
- write(11,'(a)')sq//'zchangecontext'
- end if
- else
- if (islast .and. ignorenats)
- * write(11,'(a)')sq//'ignorenats%'
- if (islast) write(11,'(a)')sq//'xchangecontext'//sq//
- * 'addspace{-'//sq//'afterruleskip}'
- * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%'
- end if
- else if (mtrnuml.eq.0.and.(ishort.eq.0.or.ishort.eq.6))
- * then
-c
-c No meter change
-c
- if (islast) then
- if (ishort .ne. 6) then
- write(11,'(a)')sq//'alaligne'
- else
- ishort = 0
- end if
- end if
- else if (ishort .ne. 0) then
- if (ishort .eq. 1) then ! Start short line
- write(shortfraq,'(f3.2)')shortfrac
- write(11,'(a)')sq//'stoppiece'//sq//'parindent 0pt'
- write(11,'(a)')sq//'vskip'//sq//'parskip'
- write(11,'(a)')sq//'hbox to'//sq//
- * 'hsize{'//sq//'vbox{'//
- * sq//'hsize='//shortfraq//sq//'hsize%'
- write(11,'(a)')sq//'contpiece'
- write(11,'(a)')sq//'makeatletter'//sq//'fil at begin'
- * //sq//'makeatother'
- ibarcnt0 = ibarcnt
- mbrsum = 0
- ishort = 2
- nmbr = 0
- else if (ishort .eq. 2) then ! End short line, no new mvt
- ntmp = ibarcnt-ibarcnt0-nmbr+mbrsum
- if (ntmp .le. 9) then
- shortfraq(1:1) = char(48+ntmp)
- lntmp = 1
- else
- write(shortfraq(1:2),'(i2)')ntmp
- lntmp = 2
- end if
- write(11,'(a)')sq//'stoppiece}}'//sq//'advance'//sq
- * //'barno'//shortfraq(1:lntmp)
-c
-c Not clear why we needed this
-c //sq//'startbarno'//sq//'barno%'
- write(11,'(a)')sq//'contpiece'
- write(11,'(a)')sq//'makeatletter'//sq//'fil at begin'
- * //sq//'makeatother'
- ishort = 0
- else if (ishort .eq. 5) then ! End short line, new mvt
- if (nobar1) then ! Continue bar numbering
- write(11,'(a)')sq//'advance'//sq
- * //'barno'//char(ibarcnt-ibarcnt0+48)
- * //sq//'startbarno'//sq//'barno%'
-c
-c Must leave in \startbarno to get msm with LMc to work.
-c
- end if
- write(11,'(a)')sq//'startpiece'//sq//'addspace'//sq
- * //'afterruleskip%'
- ishort = 0
- else if (ishort .eq. 3) then ! Mid line gap, start coda
-c May never come thru here. Stuff is done later at least for mcl.pmx
- write(shortfraq,'(f3.2)')codafrac
- write(11,'(a)')sq//'endpiece}'//sq//'advance'//sq
- * //'barno'//char(ibarcnt-ibarcnt0+48)//sq//
- * 'startbarno'//sq//'barno%'
- write(11,'(a)')sq//'hfill'//sq//
- * 'vbox{'//sq//'hsize='//shortfraq//'%'
- write(11,'(a)')sq//'contpiece'
- write(11,'(a)')sq//'makeatletter'//sq//'fil at begin'
- * //sq//'makeatother'
- ishort = 4
- else if (ishort .eq. 4) then ! End coda
- ntmp = ibarcnt-ibarcnt0-nmbr+mbrsum
- if (ntmp .le. 9) then
- shortfraq(1:1) = char(48+ntmp)
- lntmp = 1
- else
- write(shortfraq(1:2),'(i2)')ntmp
- lntmp = 2
- end if
- write(11,'(a)')sq//'endpiece}}'//sq//'advance'//sq
- * //'barno'//shortfraq(1:lntmp)
- write(11,'(a)')sq//'contpiece'
- write(11,'(a)')sq//'makeatletter'//sq//'fil at begin'
- * //sq//'makeatother'
- ishort = 0
- mbrsum = 0
- nmbr = 0
- end if
- else if (mtrnuml .ne. 0) then
-
-c
-c New meter, no new sig, end of line, not new page.
-c
-c \generalmeter{\meterfrac{3}{4}}%
-c \xchangecontext\addspace{-\afterruleskip}%
-c \zalaligne\generalmeter{\meterfrac{3}{4}}\addspace{-\afterruleskip}%
-c \zchangecontext
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (movbrk .eq. 0) then
- if (islast) then
- call wgmeter(mtrnmp,mtrdnp)
- end if
- if (mtrdnp .gt. 0) then
- if (islast) then
- write(11,'(a)')
- * sq//'let'//sq//'bnat'//sq//'barnoadd'
- * //sq//'def'//sq//'barnoadd{'//sq//'empty}%'
- write(11,'(a)')sq//'xchangecontext'//sq//
- * 'addspace{-'//sq//'afterruleskip}'//sq//
- * 'zalaligne'//sq//'let'//sq//'barnoadd'//sq//'bnat'
- call wgmeter(mtrnmp,mtrdnp)
- write(11,'(a)')sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'zchangecontext'
- end if
- if (ibar .eq. ibarmbr) xb4mbr = -.2*musicsize
- else
- if (islast) write(11,'(a)')sq//'alaligne'
- end if
- else
- if (islast) write(11,'(a)')sq//'alaligne'
- end if
- end if
- end if
-c
-c Modified 090525 to use \bnrs
-c
- if (slint) then
- slint = .false.
- if (islast) write(11,'(a16,i1,a14)')sq//'def'//sq//
- * 'raisebarno{',irzbnd,'.5'//sq//'internote}%'
- end if
- movbrk = 0
- end if
-c
-c Clean up if we squelched bar number reset at movement break
-c
- if (nobar1) then
- if (islast) write(11,'(a)')sq//'startbarno1'
- nobar1 = .false.
- end if
- read(12,*,end=14)iauto
-14 continue
-c
-c We come thru here for the 1st bar of every system, so initialize is1n1
-c
- is1n1 = 0
-c
-c Brought down from above
-c
- if (isystpg .eq. nsystp(ipage)) then
- isystpg = 0
-c
-c The following is to avoid moving this reset of isystpg, but still send a signal
-c down below for last system shortening events
-c
- if (ishort.eq.2) iflagbot = 1
- end if
-c
-c Check for linebreak ties
-c
- if (ispstie)
- * call LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat,
- * ispstie,sepsymq)
- else
-c
-c Not first bar of system
-c
- if (btest(iplnow,28)) then
-c
-c Signature change
-c
- if (mtrnuml .ne. 0) then
-c
-c Meter+signature change mid line, assume no movement break
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (islast) call wgmeter(mtrnmp,mtrdnp)
- notexq = sq//'generalsignature{'
- lnote = 18
- if (isig .lt. 0) then
- notexq = notexq(1:18)//'-'
- lnote = 19
- end if
- if (islast) then
- iptemp = 48+abs(isig)
- charq = chax(iptemp)
- notexq = notexq(1:lnote)//charq//'}%'
- lnote = lnote+3
- write(11,'(a)')notexq(1:lnote)
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- if (ignorenats) write(11,'(a)')sq//'ignorenats%'
- write(11,'(a)')sq//'xchangecontext%'
- end if
- if (ibar .eq. ibarmbr) then
-c
-c Compute space for multibar rest
-c
- if (lastisig*isig .ge. 0) then
- naccs = max(abs(lastisig),abs(isig))
- else
- naccs = abs(lastisig-isig)
- end if
-c xb4mbr = (facmtr+naccs*.24)*musicsize
- xb4mbr = -.2*musicsize
- end if
- else
-c
-c Signature change only
-c
- notexq = sq//'xbar'//sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'generalsignature{'
- lnote = 49
- if (isig .lt. 0) then
- notexq = notexq(1:49)//'-'
- lnote = 50
- end if
- if (islast)
- * write(11,'(a)')notexq(1:lnote)//chax(48+abs(isig))//'}%'
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- if (islast .and. ignorenats)
- * write(11,'(a)')sq//'ignorenats%'
- if (islast) write(11,'(a)')sq//'zchangecontext'//sq
- * //'addspace{-.5'// sq//'afterruleskip}%'
- if (ibar .eq. ibarmbr) then
-c
-c Compute space for multibar rest
-c
- if (lastisig*isig .ge. 0) then
- naccs = max(abs(lastisig),abs(isig))
- else
- naccs = abs(lastisig-isig)
- end if
-c xb4mbr = naccs*.24*musicsize
- xb4mbr = -.2*musicsize
- end if
- end if
- else if (ishort .eq. 3) then
-c
-c Gap before coda, assumed no signature change!
-c
- ntmp = ibarcnt-ibarcnt0-nmbr+mbrsum
- if (ntmp .le. 9) then
- shortfraq(1:1) = char(48+ntmp)
- lntmp = 1
- else
- write(shortfraq(1:2),'(i2)')ntmp
- lntmp = 2
- end if
- write(11,'(a)')sq//'endpiece}'//sq//'advance'//sq
- * //'barno'//shortfraq(1:lntmp)
- if (nocodabn) then
- write(11,'(a)')sq//'nobarno'
- nocodabn = .false.
- end if
- write(shortfraq,'(f3.2)')codafrac
- write(11,'(a)')sq//'hfill'//sq//
- * 'vbox{'//sq//'hsize='//shortfraq//sq//'hsize%'
- write(11,'(a)')sq//'contpiece'
- write(11,'(a)')sq//'makeatletter'//sq//'fil at begin'
- * //sq//'makeatother'
- ishort = 4
- else if (mtrnuml .eq. 0) then
-c
-c No meter change
-c
- if (islast) write(11,'(a)')sq//'xbar'
- else
-c
-c Change meter midline
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (movbrk .eq. 0) then
- if (islast) then
- call wgmeter(mtrnmp,mtrdnp)
- end if
- if (mtrdnp .gt. 0) then
- if (islast) then
- write(11,'(a,2i1,a)')sq//'newtimes0%'
- end if
-c if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize
- if (ibar .eq. ibarmbr) xb4mbr = -.2*musicsize
- else
- if (islast) write(11,'(a)')sq//'xbar'
- end if
- end if
- end if
- end if
-c
-c Now that xbar's are written, can put in left-repeats at line beginnings
-c
- if (lrptpend) then
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1'
- * //sq//'leftrepeat'
- lrptpend = .false.
- end if
- if (ibar .gt. 1) then
-c
-c For bars after first, slide all stuff down to beginning of arrays
-c
- do 11 iv = 1 , nv
- do 11 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- ioff = nib(ivx,ibar-1)
- do 12 ip = 1 , nib(ivx,ibar)-ioff
- nolev(ivx,ip) = nolev(ivx,ip+ioff)
- nodur(ivx,ip) = nodur(ivx,ip+ioff)
- nacc(ivx,ip) = nacc(ivx,ip+ioff)
- irest(ivx,ip) = irest(ivx,ip+ioff)
- islur(ivx,ip) = islur(ivx,ip+ioff)
- ipl(ivx,ip) = ipl(ivx,ip+ioff)
- iornq(ivx,ip) = iornq(ivx,ip+ioff)
- mult(ivx,ip) = mult(ivx,ip+ioff)
- if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then
- if (ivx.eq.1) then
- isfig(1,ip) = isfig(1,ip+ioff)
- else
- isfig(2,ip) = isfig(2,ip+ioff)
- end if
- end if
-12 continue
- if (ivx.le.nv .and. ncc(iv).gt.1) then
- islide = 0
- do 13 icc = 1 , ncc(iv)
- if (tcc(iv,icc) .le. lenbar) then
-c
-c This time will drop <=0 when slid.
-c
- islide = icc-1
- ncmidcc(iv,1) = ncmidcc(iv,icc)
- else
- tcc(iv,icc-islide) = tcc(iv,icc)-lenbar
- ncmidcc(iv,icc-islide) = ncmidcc(iv,icc)
- end if
-13 continue
- ncc(iv) = ncc(iv)-islide
- tcc(iv,1) = 0.
- end if
-11 continue
- do 15 ig = 1 , ngrace
- ipg(ig) = ipg(ig)-nib(ivg(ig),ibar-1)
- if (ibar .gt. 2) ipg(ig) = ipg(ig)+nib(ivg(ig),ibar-2)
-15 continue
- do 21 il = 1 , nlit
- iplit(il) = iplit(il)-nib(ivlit(il),ibar-1)
- if (ibar .gt. 2) iplit(il) = iplit(il)+nib(ivlit(il),ibar-2)
-21 continue
- do 22 it = 1 , ntrill
- iptrill(it) = iptrill(it)-nib(ivtrill(it),ibar-1)
- if (ibar .gt. 2) iptrill(it) =
- * iptrill(it)+nib(ivtrill(it),ibar-2)
-22 continue
- do 27 icrd = 1 , ncrd
- ivx = iand(15,ishft(icrdat(icrd),-8))
- * +16*igetbits(icrdat(icrd),1,28)
- ipnew = iand(255,icrdat(icrd))-nib(ivx,ibar-1)
- if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2)
- icrdat(icrd) = iand(not(255),icrdat(icrd))
- icrdat(icrd) = ior(max(0,ipnew),icrdat(icrd))
-27 continue
- do 29 iudorn = 1 , nudorn
- ivx = ivxudorn(iudorn)
- ipnew = iand(255,kudorn(iudorn))-nib(ivx,ibar-1)
- if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2)
- kudorn(iudorn) = iand(not(255),kudorn(iudorn))
- kudorn(iudorn) = ior(max(0,ipnew),kudorn(iudorn))
-29 continue
- do 42 idyn = 1 , ndyn
- idynd = idyndat(idyn)
- ivx = iand(15,idynd)+16*igetbits(idynda2(idyn),1,10)
- ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1)
-c
-c The following construction avoids array bound errors in some compilers
-c
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
- call setbits(idynd,8,4,ipnew)
- idyndat(idyn) = idynd
-42 continue
- do 43 itxtdyn = 1 , ntxtdyn
- idynd = ivxiptxt(itxtdyn)
- ivx = iand(31,idynd)
- ipnew = igetbits(idynd,8,5)-nib(ivx,ibar-1)
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
-c call setbits(idynd,8,4,ipnew)
- call setbits(idynd,8,5,ipnew)
- ivxiptxt(itxtdyn) = idynd
-43 continue
- do 41 isdat = 1 , nsdat
- isdata = isdat1(isdat)
- ivx = ivmx(igetbits(isdata,5,13),igetbits(isdata,1,12)+1)
- ipnew = igetbits(isdata,8,3)-nib(ivx,ibar-1)
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
- call setbits(isdata,8,3,ipnew)
- isdat1(isdat) = isdata
-41 continue
- do 44 ibc = 1 , nbc
- ivx = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28)
- ipnew = igetbits(ibcdata(ibc),8,4)-nib(ivx,ibar-1)
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
- call setbits(ibcdata(ibc),8,4,ipnew)
-44 continue
- do 45 iarps = 1 , NumArpShift
- IpArpShift(iarps) =
- * IpArpShift(iarps)-nib(IvArpShift(iarps),ibar-1)
- if (ibar .gt. 2) then
- IpArpShift(iarps) =
- * IpArpShift(iarps)+nib(IvArpShift(iarps),ibar-2)
- end if
-45 continue
-c
-c Bookkeeping for figures. This will set nfigs = 0 if there are no figs left.
-c If there are figs left, it will reset all times relative to start of
-c current bar.
-c
- do 46 ivx = 1 , 2
- if (figbass) then
- islide = 0
- do 20 jfig = 1 , nfigs(ivx)
- if (itfig(ivx,jfig) .lt. lenbar) then
-c
-c This figure was already used
-c
- islide = jfig
- else
- itfig(ivx,jfig-islide) = itfig(ivx,jfig)-lenbar
- figq(ivx,jfig-islide) = figq(ivx,jfig)
- itoff(ivx,jfig-islide) = itoff(ivx,jfig)
- ivupfig(ivx,jfig-islide) = ivupfig(ivx,jfig)
- ivvfig(ivx,jfig-islide) = ivvfig(ivx,jfig)
- end if
-20 continue
- nfigs(ivx) = nfigs(ivx)-islide
- end if
- if (nfigs(2) .eq. 0) go to 47
-46 continue
-47 continue
- end if
-c
-c End of sliding down for bars after first in gulp.
-c
-c The following may not be needed by makeabar, but just in case...
-c
- if (firstgulp .and. lenb0.ne.0) then
- if (ibar .eq. 1) then
- lenbar = lenb0
- else
- lenbar = lenb1
- end if
- end if
-c
-c Equal line spacing stuff
-c
- if (equalize .and. bar1syst) then
- if (isystpg .eq. 1) then
- write(11,'(a)')sq//'starteq%'
- else if (isystpg .eq. nsystp(ipage)-1) then
- write(11,'(a)')sq//'endeq%'
- end if
- end if
- call make1bar(ibmrep,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart)
- call make2bar(ninow,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart,clefq)
-c
-c Hardspace before barline?
-c
- hardb4 = 0.
- do 35 iv = 1 , nv
- do 35 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- if (btest(irest(ivx,nn(ivx)),18)) then
- nudoff(ivx) = nudoff(ivx)+1
- hardb4 = max(hardb4,udoff(ivx,nudoff(ivx)))
- end if
-35 continue
- if (hardb4 .gt. 0.) then
- if (islast) write(11,'(a11,f5.1,a4)')sq
- * //'hardspace{',hardb4,'pt}%'
-c
-c This was causing an incorrect poe in an example, which did not affect main
-c spacing, but did cause an extra accidental space to be too small
-c
- fixednew = fixednew-hardb4
- end if
-10 continue
- firstgulp = .false.
- lenb0 = 0
- go to 30
-40 close(12)
- close(13)
- ilbuf = 1
- ipbuf = 0
- wdpt = widthpt
- if (iline .eq. 1) wdpt = widthpt*(1-fracindent)
- poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/
- * (elsktot+fbar*nbarss-scaldold)
- poevec(nsyst) = poe
- if (.not.islast) then
- close(11)
- close(16)
- if (figbass) close(14)
- return
- end if
- do 19 ia = 1 , nasksys
- iask = iask+1
- ask(iask) = (wasksys(ia)/poe-abs(elasksys(ia)))/poefa(iline)
- if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.)
-19 continue
- do 26 ia = 1 , nhssys
- nhstot = nhstot+1
- hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.)
-26 continue
- if (islast .and.
- * onvolt) write(11,'(a)')sq//'endvoltabox'
- rendq = '% '
- if (ishort .ne. 0) rendq = '}}%'
- if (rptfq2 .ne. 'E') then
-c
-c Terminal repeat. Right or double?
-c
- if (rptfq2 .eq. 'r') then
- if (islast) write(11,'(a)')sq//'setrightrepeat'
- * //sq//'endpiece'//rendq
- else if (rptfq2 .eq. 'd') then
- if (islast) write(11,'(a)')sq//'setdoublebar'//sq//'endpiece'
- * //rendq
- else if (rptfq2 .eq. 'b') then
- if (islast) write(11,'(a)')sq//'endpiece'//rendq
- else if (rptfq2 .eq. 'z') then
- if (islast) write(11,'(a)')sq//'setzalaligne'//sq//'Endpiece'
- * //rendq
- else
- print*
- print*,'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2
- write(15,*)'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2
- if (islast) write(11,'(a)')sq//'Endpiece'
- end if
- else
- write(11,'(a)')sq//'Endpiece'//rendq
- end if
- if (.not.vshrink) then
- if (islast .and. bottopgap) then
- if (abs(botamt) .gt. 1.e-6) then
- if (botamt .gt. 9.95) then
- fmtq = '(a,f4.1,a)'
- else if (botamt .gt. 0.) then
- fmtq = '(a,f3.1,a)'
- else if (botamt .gt. -9.95) then
- fmtq = '(a,f4.1,a)'
- else
- fmtq = '(a,f5.1,a)'
- end if
- write(11,fmtq)sq//'null'//sq//'vskip',botamt,
- * sq//'Internote%'
- end if
- end if
- xnstbot = xnsttop(ipage)*etabot/etatop
- if (xnstbot .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else
- fmtq = '(a,f4.1,a)'
- end if
- if (islast) write(11,fmtq)sq//'vskip',xnstbot,
- * sq//'Interligne'//sq//'eject'//sq//'endmuflex'
- if (islast) write(11,'(a)')sq//'bye'
- else
- if (islast) write(11,'(a)')
- * sq//'vfill'//sq//'eject'//sq//'endmuflex'
- if (islast) write(11,'(a)')sq//'bye'
- end if
- rewind(11)
- if (figbass) then
- write(14,'(a9,i2,a10,i2,1x,a5)')
- * sq//'figdrop=',ifigdr(1,iline),
- * ' '//sq//'figdtwo=',ifigdr(2,iline),sq//'fi}%'
- rewind(14)
- end if
- call askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0)
- if (.not.optimize) then
- print*
- print*,'Writing '
- * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex'
- print*,'Done with second PMX pass.'
- write(15,'(/,a)')'Writing '
- * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex'
- write(15,'(a)')' Done with second PMX pass. Now run TeX'
- end if
- return
- end
- subroutine poestats(nsyst,poe,poebar,devnorm)
- parameter (nks=125)
-c
-c Compute avg. & norm. std. dev. of poe.
-c
- real*4 poe(nks)
- sumx = 0.
- sumxx = 0.
- do 1 isyst = 1 , nsyst
- sumx = sumx+poe(isyst)
- sumxx = sumxx+poe(isyst)**2
-1 continue
- devnorm = sqrt(nsyst*sumxx/sumx**2-1)
- poebar = sumx/nsyst
- return
- end
- subroutine precrd(ivx,ip,nolevm,nacc,ipl,irest,udq,
- * twooftwo,icashft)
-c
-c Analyzes chords, data to be used with slurs on chords and plain chords.
-c Check for 2nds, shift notes if neccesary.
-c ipl(10) chord present
-c irest(20) set if any note is right shifted
-c irest(27) set if any note is left shifted
-c ipl(8|9) left|right shift main note
-c icrdat(23|24) ditto chord note
-c udq is updown-ness, needed to analyze 2nds.
-c levtabl(i)=0 if no note at this level, -1 if main note, icrd if chord note.
-c icrdot(icrd)(27-29) sequence order of chord note if accid, top down
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- logical btest,is2nd,twooftwo
- integer*4 kicrd(10),levtabl(88)
- character*1 udq
- do 11 i = 1 , 88
- levtabl(i) = 0
-11 continue
- do 1 icrd1 = 1 , ncrd
- ivx1 = iand(15,ishft(icrdat(icrd1),-8))
- * +16*igetbits(icrdat(icrd1),1,28)
- ip1 = iand(255,icrdat(icrd1))
- if (ip1.eq.ip .and. ivx1.eq.ivx) go to 2
-1 continue
- print*
- print*,
- * 'Cannot find first chord note in precrd. Send source to Dr. Don!'
- call stop1()
-2 continue
- maxlev = nolevm
- minlev = nolevm
- levtabl(nolevm) = -1
- is2nd = .false.
- naccid = 0
- levmaxacc = -100
- levminacc = 1000
-c
-c Check 1st 3 bits of nacc for accid on main note of chord.
-c
- if (iand(7,nacc) .gt. 0) then
- naccid = 1
-c
-c Start list of notes with accid's. There will be naccid of them. kicrd=0 if main,
-c otherwise icrd value for note with accidental.
-c
- kicrd(1) = 0
- levmaxacc = nolevm
- levminacc = nolevm
-c
-c Start the level-ranking
-c
- icrdot0 = 1
- end if
- do 3 icrd2 = icrd1 , ncrd
- nolev = igetbits(icrdat(icrd2),7,12)
- levtabl(nolev) = icrd2
- maxlev = max(maxlev,nolev)
- minlev = min(minlev,nolev)
-c
-c Check for accidental
-c
- if (btest(icrdat(icrd2),19)) then
- naccid = naccid+1
- levmaxacc = max(levmaxacc,nolev)
- levminacc = min(levminacc,nolev)
-c
-c Add this icrd to list of values for notes with accid's.
-c
- kicrd(naccid) = icrd2
- if (.not.btest(nacc,28)) then
-c
-c Order not forced, so get the level-ranking, top down
-c
- iorder = 1
- do 12 iaccid = 1 , naccid-1
- if (kicrd(iaccid) .eq. 0) then
- if (nolevm .gt. nolev) then
- iorder = iorder+1
- else
- icrdot0 = icrdot0+1
- end if
- else
- if (igetbits(icrdat(kicrd(iaccid)),7,12)
- * .gt. nolev) then
- iorder = iorder+1
- else
- iold = igetbits(icrdot(kicrd(iaccid)),3,27)
- call setbits(icrdot(kicrd(iaccid)),3,27,iold+1)
- end if
- end if
-12 continue
- call setbits(icrdot(icrd2),3,27,iorder)
- end if
- end if
-c
-c Exit loop if last note in this chord
-c
- if (icrd2 .eq. ncrd) go to 4
- if (igetbits(icrdat(icrd2+1),8,0) .ne. ip .or.
-c * igetbits(icrdat(icrd2+1),4,8) .ne. ivx) go to 4
- * igetbits(icrdat(icrd2+1),4,8)
- * +16*igetbits(icrdat(icrd2+1),1,28) .ne. ivx) go to 4
-3 continue
- print*
- print*,'Failed to find last chord note. Send source to Dr. Don!'
- call stop1()
-4 continue
-c
-c Now icrd1, icrd2 define range of icrd for this chord.
-c
-c Bypass autos-shifting if any manual shifts are present
-c
- if (btest(irest,20) .or. btest(irest,27)) go to 10
-c
-c Check for 2nds
-c
- do 5 ilev = 1 , 87
- if (levtabl(ilev).ne.0 .and. levtabl(ilev+1).ne.0) then
-c
-c There is at least one 2nd..
-c
- if (udq .eq. 'u') then
-c
-c Upstem. Start with 2nd just found and go up, rt-shifting upper
-c member of each pair
-c
- ile = ilev
-c
-c Set main-note flag for ANY right-shift
-c
- irest = ibset(irest,20)
-7 continue
- if (levtabl(ile+1) .lt. 0) then
-c
-c Upstem, & upper member is main so must be rt-shifted. This would move
-c stem too, so we rt-shift the OTHER note, and set flag that signals
-c to interchange pitches just when these two notes are placed.
-c
- nacc = ibset(nacc,30)
- icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),24)
- else
-c
-c Upper member is chord note, must be rt-shifted
-c
- icrdat(levtabl(ile+1)) = ibset(icrdat(levtabl(ile+1)),24)
- end if
- ile = ile+1
-8 continue
- ile = ile+1
- if (ile .lt. 87) then
- if (levtabl(ile).ne.0 .and. levtabl(ile+1).ne.0) then
- go to 7
- else
- go to 8
- end if
- end if
- go to 10
- else
-c
-c Downstem. Start at top and work down, left-shifting lower member of each pair.
-c We know that lowest pair is at (ilev,ilev+1).
-c
- ile = 88
-c
-c Set main-note flag for ANY right-shift
-c
- irest = ibset(irest,27)
-9 continue
- if (levtabl(ile).ne.0 .and. levtabl(ile-1).ne.0) then
- if (levtabl(ile-1) .lt. 0) then
-c ipl = ibset(ipl,8)
-c
-c Dnstem, & lower member is main so must be left-shifted. This would move
-c stem too, so we left-shift the OTHER note, and set flag that signals
-c to interchange pitches just when these two notes are placed.
-c
- nacc = ibset(nacc,31)
- icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),23)
- else
-c
-c Lower member is chord note, must be shifted
-c
- icrdat(levtabl(ile-1)) =
- * ibset(icrdat(levtabl(ile-1)),23)
- end if
- ile = ile-1
- end if
- ile = ile-1
- if (ile .ge. ilev+1) go to 9
- go to 10
- end if
- end if
-5 continue
-10 continue
-c
-c Done with 2nds, now do accid's. Call even if just one, in case left shifts.
-c
-c if (naccid .gt. 1) call crdaccs(nacc,ipl,irest,naccid,
- if (naccid .ge. 1) call crdaccs(nacc,ipl,irest,naccid,
- * kicrd,nolevm,levmaxacc,levminacc,icrdot0,twooftwo,icashft)
- return
- end
- subroutine printl(string)
- character*(*) string
-c
-c Send string to console and to log file
-c
- print*,string
- write(15,'(a)')string
- return
- end
- subroutine putarp(tnow,iv,ip,nolev,ncm,soutq,lsout)
- parameter (nm=24)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtol/ tol
- common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20),
- * ArpShift(20)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- logical lowdot,IsArpShift
- character*80 soutq
- character*79 notexq
- character*8 symq(2)
- character*1 chax
- data symq /'raisearp','arpeggio'/
-c
-c NOTE iv in arg list is really ivx, referring to voice rather than staff.
-c
-c Find which iarp, if any
-c
- do 1 iarp = 1 , narp
- if (abs(tnow-tar(iarp)).lt.tol) go to 2
-1 continue
-c
-c If here, this is the *first* call for this arp.
-c
- narp = narp+1
- tar(narp) = tnow+tol*.5
- ivar1(narp) = iv
- ipar1(narp) = ip
- levar1(narp) = nolev
- ncmar1(narp) = ncm
- return
-2 continue
-c
-c If here, this is *second* call at this time, narp points to values from 1st.
-c
-c Check for shift. Set IsArpShift and iarps
-c
- do 3 iarps = 1 , NumArpShift
- if (IvArpShift(iarps) .eq. ivar1(iarp) .and.
- * IpArpShift(iarps) .eq. ipar1(iarp)) then
- IsArpShift = .true.
- notexq = chax(92)//'loffset{'
- write(notexq(10:14),'(f3.1,a2)') Arpshift(iarps),'}{'
- lnote = 14
- go to 4
- end if
-3 continue
- IsArpShift = .false.
- lnote = 0
-4 continue
- if (iv .eq. ivar1(iarp)) then
-c
-c Arp is in a single voice.
-c
- levbot = min(levar1(iarp),nolev)-ncm+3
- invert = abs(levar1(iarp)-nolev)+1
- else
-c
-c Arp covers >1 voice. Lower voice has to be the first, upper is current and
-c is where the symbol will be written.
-c Check whether ivx's ivar1(iarp) & iv are in same staff
-c
- do 5 iiv = 1 , nm
- if (ivmx(iiv,1).eq.ivar1(iarp) .or. (nvmx(iiv).eq.2.and.
- * ivmx(iiv,2).eq.ivar1(iarp))) then
- iivivx1 = iiv
- go to 6
- end if
-5 continue
- print*,'Screwup#1 in putarp'
- stop
-6 continue
- do 7 iiv = 1 , nm
- if (ivmx(iiv,1).eq.iv .or. (nvmx(iiv).eq.2.and.
- * ivmx(iiv,2).eq.iv)) go to 8
-c
-c Found iv for both voices (iivivx1, iiv), done looking
-c
-7 continue
- print*,'Screwup#2 in putarp'
- stop
-8 continue
- if (iivivx1 .eq. iiv) then
- nstaffshift = 0
- else
- nstaffshift = -nint(2*xinsnow)
- end if
-c levbot = -nint(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp)
- levbot = nstaffshift+3+levar1(iarp)-ncmar1(iarp)
- invert = -levbot+4+nolev-ncm
- end if
-c
-c isym will be (1,2) if invert is (even,odd). If even, raise .5\internote
-c
- isym = mod(invert,2)+1
- ilvert = (invert+1)/2
- if (levbot .ge. 0 .and. levbot .le. 9) then
-c
-c Single digit
-c
- if (.not.IsArpShift) then
- notexq = chax(92)//symq(isym)//chax(48+levbot)
- else
- notexq = notexq(1:lnote)//
- * chax(92)//symq(isym)//chax(48+levbot)
- end if
- lnote = lnote+10
- else
- if (.not.IsArpShift) then
- notexq = chax(92)//symq(isym)//'{'
- else
- notexq = notexq(1:lnote)//chax(92)//symq(isym)//'{'
- end if
- lnote = lnote+10
- if (levbot .ge. -9) then
-c
-c Need two spaces for number
-c
- write(notexq(lnote+1:lnote+3),'(i2,a1)')levbot,'}'
- lnote = lnote+3
- else
- write(notexq(lnote+1:lnote+4),'(i3,a1)')levbot,'}'
- lnote = lnote+4
- end if
- end if
-c if (ilvert .le. 9) then
-c call addstr(notexq(1:lnote)//chax(48+ilvert),lnote+1,
-c * soutq,lsout)
-c else
-c write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}'
-c call addstr(notexq(1:lnote+4),lnote+4,soutq,lsout)
-c end if
-
- if (ilvert .gt. 9) then
- write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//chax(48+ilvert)
- lnote = lnote+1
- end if
- if (IsArpShift) then
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq(1:lnote),lnote,soutq,lsout)
-c
-c cancel out the stored time, to permit two arps at same time!
-c
- tar(iarp) = -1.
- return
- end
- subroutine putast(elask,indxask,outq)
- character*129 outq,tag
- character*9 fmtq
- if (elask .ge. 0.) then
- if (elask.lt.0.995) then
- lp = 3
- else if (elask .lt. 9.995) then
- lp = 4
- else
- lp = 5
- end if
- write(fmtq,'(a5,i1,a3)')'(a2,f',lp,'.2)'
- else
- lp = 5
- fmtq = '(a2,f5.1)'
- end if
-c
-c Overwrite as follows: ...xyz*ask *lmnop... ->
-c ...xyz*ast{.nn}*lmnop...
-c ...xyz*ast{n.nn}*lmnop...
-c ...xyz*ast{nn.nn}*lmnop...
-c or for negative, ...xyz*ast{-nn.n}*lmnop...
- tag = outq(indxask+9:)
- write(outq(indxask+3:),fmtq)'t{',elask
- outq = outq(1:indxask+4+lp)//'}'//tag
- return
- end
- subroutine putcb(ivx,ip,notexq,lnote)
- common /comcb/ nbc,ibcdata(36)
- character*79 notexq
- logical btest
-c ivxip = ivx+16*ip
- do 1 ibc = 1 , nbc
-c if (ivxip .eq. iand(1023,ibcdata(ibc))) go to 2
-c if (ivx.eq.iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28)
-c * .and. ip.eq.iand(1008,ibcdata(ibc))) go to 2
- ivxbc = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28)
- ipbc = igetbits(ibcdata(ibc),8,4)
- if (ivx .eq. ivxbc .and. ip .eq.ipbc) go to 2
-1 continue
- call printl('Error in putbc, Call Dr. Don')
- stop
-2 continue
- if (btest(ibcdata(ibc),27)) then
- lnote = 8
- notexq = char(92)//'pbreath'
- else
- lnote = 9
- notexq = char(92)//'pcaesura'
- end if
- ivshft = igetbits(ibcdata(ibc),6,13)
-c?? ivshft = igetbits(ibcdata(ibc),6,13)-32
- if (ivshft .gt. 0) ivshft = ivshft-32
- if (ivshft.lt.0 .or. ivshft.gt.9) then
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (ivshft .lt. -9) then
- write(notexq(lnote+1:lnote+3),'(i3)')ivshft
- lnote = lnote+3
- else
- write(notexq(lnote+1:lnote+2),'(i2)')ivshft
- lnote = lnote+2
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- else
- notexq = notexq(1:lnote)//char(48+ivshft)
- lnote = lnote+1
- end if
- ihshft = igetbits(ibcdata(ibc),8,19)
- if (ihshft .eq. 0) then
- notexq = notexq(1:lnote)//'0'
- lnote = lnote+1
- else
- hshft = .1*(ihshft-128)
-c
-c -12.8<hshft<12.8
-c
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (hshft .lt. -9.95) then
- write(notexq(lnote+1:lnote+5),'(f5.1)')hshft
- lnote = lnote+5
- else if (hshft.lt.-0.05 .or. hshft.gt.9.95) then
- write(notexq(lnote+1:lnote+4),'(f4.1)')hshft
- lnote = lnote+4
- else
- write(notexq(lnote+1:lnote+3),'(f3.1)')hshft
- lnote = lnote+3
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- return
- end
- subroutine putfig(ivx,ifig,offnsk,figcheck,soutq,lsout)
- parameter (nm=24)
- common /comfig/ itfig(2,74),figqq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2,ivvfig(2,74)
- character*10 figqq,figq
- character*80 soutq,notexq
- character*1 ch1q,ch2q,sq,chax
- character*5 nofq,nofaq
- character*4 Figutq,Conttq
- logical figcheck
- if (ivx .eq. 1) then
- Figutq = 'Figu'
- Conttq = 'Cont'
- else
- Figutq = 'Figt'
- Conttq = 'Cott'
- end if
- sq = chax(92)
- if (ivvfig(ivx,ifig) .ne. 0) then
-c
-c Alter figdrop
-c
- notexq = sq//'global'//sq//'advance'//sq//'figdrop'
- lnote = 23
- if (ivvfig(ivx,ifig) .lt. 0) then
- notexq = notexq(1:lnote)//'-'
- lnote = lnote+1
- endif
- notexq = notexq(1:lnote)//char(48+abs(ivvfig(ivx,ifig)))
- lnote = lnote+1
- call addstr(notexq,lnote,soutq,lsout)
- end if
- if (abs(offnsk) .gt. .0001) then
-c
-c Write offset for floating figure, to two decimal places
-c
- notexq = sq//'off{'
- if (-offnsk .lt. -9.995) then
- write(notexq(6:11),'(f6.2)')-offnsk
- lnote = 11
- else if (-offnsk.lt.-.995 .or. -offnsk.gt.9.995) then
- write(notexq(6:10),'(f5.2)')-offnsk
- lnote = 10
- else if (-offnsk.lt.-.0001 .or. -offnsk.gt..995) then
- write(notexq(6:9),'(f4.2)')-offnsk
- lnote = 9
- else
- write(notexq(6:8),'(f3.2)')-offnsk
- lnote = 8
- end if
- notexq = notexq(1:lnote)//sq//'noteskip}'
- call addstr(notexq,lnote+10,soutq,lsout)
- end if
- figq = figqq(ivx,ifig)
- ic = 1
-c nof = 0
-c nofa = -1
- nof = -ivupfig(ivx,ifig)
- nofa = -ivupfig(ivx,ifig)-1
-c
-c Beginning of manual loop
-c
-1 ch1q = figq(ic:ic)
-c
-c Exit when first blank is encountered
-c
- if (ch1q .eq. ' ') go to 2
-c
-c Starting a level. Set up vertical offset.
-c
-c lnof = 1
-c nofq = chax(nof+48)
-c if (nof .gt. 9) then
-c lnof = 2
-c nofq = '1'//chax(nof-10+48)
-c end if
-c if (nofa .eq.-1) then
-c lnofa = 2
-c nofaq = '-1'
-c else if (nofa .lt. 10) then
-c lnofa = 1
-c nofaq = chax(nofa+48)
-c else
-c lnofa = 2
-c nofaq = '1'//chax(nofa+38)
-c end if
- call istring(nof,nofq,lnof)
- call istring(nofa,nofaq,lnofa)
- if (ch1q .eq. '0') then
-c
-c Continuation figure. Next number is length (in noteskips). The number will
-c end at the first blank or char that is not digit or decimal point. If
-c colon, it is a separator and must be skipped
-c
- icnum = ic+1
-3 continue
- ic = ic+1
- if (index('0123456789.',figq(ic:ic)) .gt. 0) go to 3
- lnum = ic-icnum
- call addstr(sq//Conttq//nofq(1:lnof)//'{'
- * //figq(icnum:ic-1)//'}',7+ic-icnum+lnof,soutq,lsout)
- if (figq(ic:ic) .ne. ':') ic=ic-1
- else if (ch1q.eq.'#'.or.ch1q.eq.'-'.or.ch1q.eq.'n') then
- ic = ic+1
- ch2q = figq(ic:ic)
- if (ch2q .eq. ' ') then
-c
-c Figure is a stand-alone accidental, so must be centered
-c
- if (ch1q .eq. '#') then
- call addstr(sq//Figutq//nofaq(1:lnofa)//
- * '{'//sq//'sharpfig}',16+lnofa,soutq,lsout)
- else if (ch1q .eq. '-') then
- call addstr(sq//Figutq//nofaq(1:lnofa)//
- * '{'//sq//'flatfig}',15+lnofa,soutq,lsout)
- else if (ch1q .eq. 'n') then
- call addstr(sq//Figutq//nofaq(1:lnofa)//
- * '{'//sq//'natfig}',14+lnofa,soutq,lsout)
- end if
- go to 2
- else
-c
-c Figure is an accidental followed by a number
-c First put the accidental (offset to the left)
-c
- if (ch1q .eq. '#') then
- call addstr(sq//Figutq//
- * nofaq(1:lnofa)//'{'//sq//'fsmsh}',
- * 13+lnofa,soutq,lsout)
- else if (ch1q .eq. '-') then
- call addstr(sq//Figutq//
- * nofaq(1:lnofa)//'{'//sq//'fsmfl}',
- * 13+lnofa,soutq,lsout)
- else if (ch1q .eq. 'n') then
- call addstr(sq//Figutq//
- * nofaq(1:lnofa)//'{'//sq//'fsmna}',
- * 13+lnofa,soutq,lsout)
- end if
-c
-c Now put the number
-c
- call addstr(sq//Figutq//nofq(1:lnof)//'{'//ch2q//'}',
- * 8+lnof,soutq,lsout)
- endif
- else if (ch1q .eq. '_') then
-c
-c Placeholder only (for lowering a figure). Don't do anything!
-c
- continue
- else
-c
-c Figure is a single number, maybe with s after
-c
- call addstr(sq//Figutq//nofq(1:lnof)//'{',
- * 6+lnof,soutq,lsout)
- ch2q = figq(ic+1:ic+1)
- if (ch2q .eq. 's') then
-c
-c Use a special character. Insert font call
-c
- ic = ic+1
- call addstr(sq//'ligfont',8,soutq,lsout)
- end if
- call addstr(ch1q//'}',2,soutq,lsout)
-c call addstr(sq//Figutq//nofq(1:lnof)//'{'//ch1q//'}',
-c * 8+lnof,soutq,lsout)
- end if
- if (ic .ge. 10) go to 2
- ic = ic+1
- nof = nof+4
- nofa = nofa+4
- go to 1
-2 continue
- if (abs(offnsk) .gt. .0001) then
- notexq = sq//'off{'
- if (offnsk .lt. -9.995) then
- write(notexq(6:11),'(f6.2)')offnsk
- lnote = 11
- else if (offnsk.lt.-.995 .or. offnsk.gt.9.995) then
- write(notexq(6:10),'(f5.2)')offnsk
- lnote = 10
- else if (offnsk.lt.-.0001 .or. offnsk.gt..995) then
- write(notexq(6:9),'(f4.2)')offnsk
- lnote = 9
- else
- write(notexq(6:8),'(f3.2)')offnsk
- lnote = 8
- end if
- notexq = notexq(1:lnote)//sq//'noteskip}'
- call addstr(notexq,lnote+10,soutq,lsout)
- end if
- if (ifig .lt. nfigs(ivx)) then
- ifig = ifig+1
- else
- nfigs(ivx) = 0
- figcheck = .false.
- end if
- return
- end
- subroutine putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx,
- * ncm,islur,nvmx,nv,ihornb,stemlin,outq,lout,ip,islhgt,
- * beamon,iscrd)
-c
-c All args are individual array element *values* except nornb,ihornb,ulq.
-c notcrd = .true. if ornament is on main note.
-c nolevm is level of main note (for chords)
-c
- parameter (nm=24)
- character*1 ulpzq,ulq(nm,9),udqq,sq,chax
- character*8 noteq
- character*79 notexq,outq
- integer*4 ihornb(nm,24),nornb(nm)
- logical btest,iscrd,usehornb,beamon
- common /comivxudorn/ivxudorn(63)
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- sq = chax(92)
- lout = 0
- usehornb = .false.
- if (nodur .lt. 64) then
- stemlen = stemlin
- else
- stemlen = 0.
- end if
-c
-c Get up-downness. ulpzq is opposite from stem direction for both beams and
-c non beams. Can use in name of ornament [ . or _ ]
-c
- if (beamon) then
- if (ulq(ivx,ibmcnt) .eq. 'u') then
- ulpzq = 'l'
- else
- ulpzq = 'u'
- end if
- else
- if (udqq(nolevm,ncm,islur,nvmx,ivx,nv).eq.'l' ) then
- ulpzq = 'u'
- else
- ulpzq = 'l'
- end if
- end if
-c
-c To enable >1 ornament on a note, next line is top of manual loop.
-c
-2 continue
-c
-cc Bit # of last ornament (last of bits 0-21)
-cc Bit # of last ornament (last of bits 0-24)
-c Bit # of last ornament (last of bits 0-24,29-30)
- if (btest(iornq,29)) then
- ibit = 29
- else if (btest(iornq,30)) then
- ibit = 30
- else
- ibit = log2(iand(iornq,4194303))
-c ibit = log2(iand(iornq,33554431))
- end if
- iornt = 2**ibit
-c
-c Begin routine to set height. Bits 0-13: (stmgx+Tupf._)
-c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n
-c 19-20: >^, 21: ? (with or w/o 16-18)
-c and 29-30: C (coda), G (new segno)
-c
-c Do not use beam height for . or _
-c
- if (btest(iornq,22) .and. iand(iornt,6144).eq.0) then
-c
-c Height is set by special beam stuff.
-c Do not leave ihorn set, do separately for every ornament
-c
- ihorn = ihornb(ivx,nornb(ivx))
- if (ulpzq .eq. 'u') ihorn = ihorn-2
-c
-c Following flag tells whether to increment nornb when exiting the subroutine.
-c
- usehornb = .true.
- else if (ibit .eq. 14) then
-c
-c Down fermata. Don't worry about upper chord notes.
-c
- if (ulpzq .eq. 'l') then
- ihorn = min(nolev,ncm-3)
- else
- ihorn = min(nolev-stemlen,ncm-3.)
- end if
- else if (btest(iornt,13) .or. btest(iornt,0)) then
-c
-c ( or )
-c
- ihorn = nolev
- else if (iand(iornt,6144) .gt. 0) then
-c
-cc Staccato . or tenuto _ , but not special beam stuff. Need up-down info
-c NOTE: removed .&_ from special beam treatment.
-c Staccato . or tenuto _ Need up-down info
-c
- if (.not.iscrd .or. (maxlev.ne.nolev.and.ulpzq.eq.'l') .or.
- * (minlev.ne.nolev.and.ulpzq.eq.'u')) then
- ihorn = nolev
- else if (maxlev .eq. nolev) then
- ulpzq = 'u'
- ihorn = max(nolev+stemlen,ncm+3.)
- else
- ulpzq = 'l'
- ihorn = min(nolev-stemlen,ncm-3.)
- end if
- else if (iscrd .and. nolev .eq. minlev) then
- if (ulpzq .eq. 'l') then
- ihorn = min(nolev-3,ncm-6)
- else
- ihorn = min(nolev-nint(stemlen)-3,ncm-6)
- end if
- else if (ibit.eq.10 .and. nolev.gt.90) then
-c
-c Special treatment for fermata on a shifted rest
-c
- ihorn = ncm+5
- else if (ulpzq.eq.'l') then
-c
-c (iscrd and nolev=maxlev) or (.not.iscrd)
-c
- ihorn = max(nolev+stemlen+2,ncm+5.)
- else if (ibit.eq.29 .or. ibit.eq.30) then
-c
-c coda or new segno, no height tweak
-c
- ihorn = ncm+5
- else
- ihorn = max(nolev+2,ncm+5)
- end if
- ioff = 0
- iclracc = 0
-c
-c Begin routine to set name. Bits 0-13: (stmgx+Tupf._)
-c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n
-c
- if (btest(iornt,2)) then
- notexq = sq//'shake'
- lnote = 6
- else if (btest(iornt,3)) then
- notexq = sq//'mordent'
- lnote = 8
- else if (btest(iornt,1)) then
- notexq = sq//'mtr'
- lnote = 4
- else if (btest(iornt,5)) then
- notexq = sq//'xtr'
- lnote = 4
- else if (btest(iornt,6)) then
- notexq = sq//'ptr'
- lnote = 4
- else if (btest(iornt,13)) then
- notexq = sq//'rpn'
- lnote = 4
- else if (btest(iornt,0)) then
- notexq = sq//'lpn'
- lnote = 4
- else if (btest(iornt,12)) then
- notexq = sq//ulpzq//'st'
- lnote = 4
- else if (btest(iornt,11)) then
- notexq = sq//ulpzq//'pz'
- lnote = 4
- else if (btest(iornt,8)) then
- notexq = sq//'upz'
- lnote = 4
- ioff = -2
- else if (btest(iornt,9)) then
- notexq = sq//'uppz'
- lnote = 5
- ioff = -2
- else if (btest(iornt,10)) then
- if (nodur .lt. 48) then
- notexq = sq//'fermataup'
- else
- notexq = sq//'Fermataup'
- end if
- lnote = 10
- ioff = -2
- else if (btest(iornt,14)) then
- if (nodur .lt. 48) then
- notexq = sq//'fermatadown'
- else
- notexq = sq//'Fermatadown'
- end if
- lnote = 12
- else if (btest(iornt,21)) then
-c
-c "?" in editorial ornament. Clear bit 16-18 after use, since ibit=21
-c
- if (btest(iornq,16)) then
- notexq = sq//'qsharp'
- lnote = 7
- ioff = 2
- iornq = ibclr(iornq,16)
- iclracc = 16
- else if (btest(iornq,17)) then
- notexq = sq//'qflat'
- lnote = 6
- ioff = 1
- iornq = ibclr(iornq,17)
- iclracc = 17
- else if (btest(iornq,18)) then
- notexq = sq//'qnat'
- lnote = 5
- ioff = 2
- iornq = ibclr(iornq,18)
- iclracc = 18
- else
- notexq = sq//'qedit'
- lnote = 6
- ioff = 0
- end if
- else if (btest(iornt,16)) then
- notexq = sq//'esharp'
- lnote = 7
- ioff = 2
- else if (btest(iornt,17)) then
- notexq = sq//'eflat'
- lnote = 6
- ioff = 1
- else if (btest(iornt,18)) then
- notexq = sq//'enat'
- lnote = 5
- ioff = 2
- else if (btest(iornt,19)) then
- notexq = sq//'usf'
- lnote = 4
- ioff = -2
- else if (btest(iornt,20)) then
- notexq = sq//'usfz'
- lnote = 5
- ioff = -2
- else if (btest(iornt,29)) then
- notexq = sq//'ccoda'
- lnote = 6
- else if (btest(iornt,30)) then
- notexq = sq//'ssegno'
- lnote = 7
- end if
- iudorn = 0
-c
-c User-defined level shift of ornament from default?
-c
- if (btest(iornq,25)) then
-c
-c Find which (if any) element of kudorn has the shift.
-c
- do 3 iudorn = 1 , nudorn
-c if (ibit .lt. 21) then
-c if (ibit.lt.21 .or. ibit.eq.29) then
- if (ibit.lt.21 .or. ibit.eq.29 .or. ibit.eq.30) then
- ibitt = ibit
-c
-c Could have oes, but not oe? or oes?
-c
- else if (iclracc .gt. 0) then
-c
-c Earlier cleared edit. accid, meaning it was oes?
-c
- ibitt = iclracc+6
- else
- ibitt = 21
- end if
- ibitt=ip+ishft(mod(ivx,16),8)+ishft(nolev,12)+ishft(ibitt,19)
-c if (ibitt .eq. iand(33554431,kudorn(iudorn))) go to 4
- if (ibitt .eq. iand(33554431,kudorn(iudorn))
- * .and. ivx.eq.ivxudorn(iudorn)) go to 4
-3 continue
-c
-c Nothing shifted on this note; exit this if block
-c
- iudorn = 0
- go to 5
-4 continue
- ioffinc = iand(63,ishft(kudorn(iudorn),-25))-32
- if (ibit.eq.19 .and. ioffinc .lt. -7) then
-c
-c Convert usf to lsf. The reason has to do with positioning being impossile
-c for some mysterious reason when you drop \usf below the staff
-c
- notexq = sq//'lsf'
- ioffinc = ioffinc+6
- end if
- ioff = ioff+ioffinc
- end if
-5 continue
-c
-c Shift level to avoid slur. Conditions are
-c 1. There is a slur
-c 2. No user-defined orn height shift (btest(iornq,25))
-c 3. upslur (islhgt>0)
-c 4. ornament is not segno(4), ._)(11-13), down ferm(14) or "(" (0) Bin=30737
-c 5. islhgt+3 >= height already computed.
-c
- if (.not.btest(iornq,25) .and.
- * islhgt.gt.0 .and. iand(iornt,30737).eq.0)
- * ioff = ioff+dim(islhgt+3,ihorn )
- call notefq(noteq,lnoten,ihorn+ioff,ncm)
- if (lnoten.eq.1) call addblank(noteq,lnoten)
- if (iand(iornt,32896) .gt. 0) then
-c
-c T-trill or trill w/o "tr"
-c
- call dotrill(ivx,ip,iornt,noteq,lnoten,notexq,lnote)
- else
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- end if
- if (iudorn .gt. 0) then
- if (btest(kudorn(iudorn),31)) then
-c
-c Horizontal shift
-c
- lform = lfmt1(ornhshft(iudorn))
- write(noteq(1:lform),'(f'//chax(48+lform)//'.1)')
- * ornhshft(iudorn)
- notexq = sq//'roffset{'//noteq(1:lform)//'}{'
- * //notexq(1:lnote)//'}'
- lnote = lnote+lform+12
- ornhshft(iudorn) = 0.
- kudorn(iudorn) = ibclr(kudorn(iudorn),31)
- end if
- end if
-c
-c Zero out the bit for ornament just dealt with.
-c
- iornq = ibclr(iornq,ibit)
- if (lout .eq. 0) then
- outq = notexq(1:lnote)
- else
- outq = outq(1:lout)//notexq(1:lnote)
- end if
- lout = lout+lnote
-c
-c Check bits 0-21, go back if any are still set
-c If bit 29 or 30 had been set, would have been used first time thru,
-c and you wouldn't use both coda and segno on same note
-c
- if (iand(iornq,4194303) .gt. 0) go to 2
- if (usehornb) nornb(ivx) = nornb(ivx)+1
- return
- end
- subroutine putshft(ivx,onoff,soutq,lsout)
- parameter (nm=24)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- character*80 soutq,notexq
- character*1 sq,chax
- logical onoff
- sq = chax(92)
-c
-c Start user-defined offsets X(...): or X(...)S
-c
- if (onoff) nudoff(ivx) = nudoff(ivx)+1
-c
-c Xoff is in pts. Round off to nearest .1. Will use at end of shift.
-c
- xoff = udoff(ivx,nudoff(ivx))
- xoff = sign(int(10.*abs(xoff)+.5)/10.,xoff)
- if (.not.onoff) xoff = -xoff
- if (xoff .lt. -9.95) then
- ifmt = 5
- else if (xoff.lt.-.95 .or. xoff.gt.9.95) then
- ifmt = 4
- else
- ifmt = 3
- end if
- write(notexq,'(f'//chax(48+ifmt)//'.1)')xoff
- call addstr(sq//'off{'//notexq(1:ifmt)//'pt}',8+ifmt,
- * soutq,lsout)
- return
- end
- subroutine puttitle(inhnoh,xnsttop,etatop,sq,etait,etatc,
- * etacs1,nv,vshrink,sepsymq)
-c
-c Called once per page, at top of page! If vshrink, only called for p.1.
-c Actual titles only allowed on p.1. (set by headlog).
-c 3/18/01: The above comment is probably bogus...can use Tt on later pages.
-c
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /cominbot/ inbothd
- character*127 notexq
- character*120 instrq,titleq,compoq
- parameter (nm=24)
- character*1 sq,sepsymq(nm),chax
- logical headlog,vshrink
- notexq = sq//'znotes'
- lenline = 7
- do 22 iv = 1 , nv-1
- notexq = notexq(1:lenline)//sepsymq(iv)
- lenline = lenline+1
-22 continue
- notexq = notexq(1:lenline)//sq//'zcharnote{'
- lenline = lenline+11
- if (.not.headlog) then
- inhead = inhnoh
- end if
- if (vshrink .and. usevshrink) then
- inhead = 16
- end if
- ndig = int(alog10(inhead+.01))+1
- write(notexq(lenline+1:lenline+ndig+10),'(i'//chax(48+ndig)//
- * ',a10)')inhead,'}{'//sq//'titles{'
- lenline = lenline+ndig+10
-c
-c Vertical skip at top of page (\Il) = etatop*glueil. Needed whether
-c headers are present or not.
-c
- glueil = xnsttop/etatop
- vskil = etatop*glueil
- if (vshrink .and. usevshrink) vskil = 2
- call writflot(vskil,notexq,lenline)
- if (.not.headlog) then
- if (islast) write(11,'(a)')notexq(1:lenline)
- * //'}{}{0}{}{0}{}{0}}'//sq//'en%'
- else
- notexq = notexq(1:lenline)//'}{'
- lenline = lenline+2
- lcq = lenstr(instrq,120)
- if (lcq .gt. 0) then
- xitil = etait*glueil
- if (vshrink .and. usevshrink) xitil = 2
- notexq = notexq(1:lenline)//instrq(1:lcq)//'}{'
-c
-c Null out instrument once used
-c
- instrq = ' '
- lenline = lenline+lcq+2
- call writflot(xitil,notexq,lenline)
- else
- notexq = notexq(1:lenline)//'}{0'
- lenline = lenline+3
- end if
- if (islast) write(11,'(a)')notexq(1:lenline)//'}%'
- notexq = '{'
- lenline = 1
- lcq = lenstr(titleq,120)
- if (lcq .gt. 0) then
- notexq = notexq(1:lenline)//titleq(1:lcq)
- lenline = lenline+lcq
- else
- call printl(' ')
- call printl('WARNING')
- call printl(
- * ' In a title block, you have specified instrument and/or')
- call printl(
- * ' composer but no title for the piece.')
- end if
- notexq = notexq(1:lenline)//'}{'
- lenline = lenline+2
- xtcil = etatc*glueil
- lcq = lenstr(compoq,120)
- if (lcq .eq. 0) xtcil = 2*xtcil
- if (vshrink .and. usevshrink) xtcil = 2
- call writflot(xtcil,notexq,lenline)
- notexq = notexq(1:lenline)//'}{'
- lenline = lenline+2
- if (lcq .gt. 0) then
- notexq = notexq(1:lenline)//compoq(1:lcq)//'}{'
- lenline = lenline+2+lcq
-c
-c Null out compoq so it does not get written later
-c
- compoq = ' '
- xcsil = etacs1*glueil
- if (vshrink .and. usevshrink) xcsil = 2
- call writflot(xcsil,notexq,lenline)
- else
- notexq = notexq(1:lenline)//'}{0'
- lenline = lenline+3
- end if
- if (islast) write(11,'(a)')notexq(1:lenline)//'}}'//sq//'en%'
- headlog = .false.
- end if
- return
- end
- subroutine putxtn(ntupv,iflop,multb,iud,wheadpt,poenom,
- * nolev1,islope,slfac,xnlmid,islur,lnote,notexq,ncmid,nlnum,
-c * eloff,iup,irest,usexnumt)
- * eloff,iup,irest,mult,usexnumt)
-c
-c Places digit for xtuplet.
-c
- character*1 chax
- character*8 noteq
- character*79 notexq
- logical btest,usexnumt
- if (iflop.ne.0 .and. multb.gt.0) then
-c
-c Number goes on beam side, move R/L by .5 wheadpt for upper/lower
-c
- eloff = eloff-0.5*iud*wheadpt/poenom
-c
-c Number goes on beam side, must use beam parameters to set pos'n
-c
- nlnum = nolev1+islope/slfac*eloff+iup*(multb+8)
- if (multb .ge. 2) nlnum = nlnum+iup
- else
- nlnum = nint(xnlmid-1+3*iud+iflop*11)
- end if
- if (.not.btest(islur,31)) then
-c
-c Only print number when wanted. First check vert, horiz offset
-c
- if (btest(irest,1)) nlnum = nlnum+igetbits(mult,8,16)-64
- if (btest(irest,7)) eloff = eloff+
- * (.1*iand(31,ishft(irest,-9))-1.6)*wheadpt/poenom
- if (.not.usexnumt) then
- notexq = chax(92)//'xnum{'
- lnote = 10
- istrtn = 7
- else
- notexq = chax(92)//'xnumt{'
- lnote = 11
- istrtn = 8
- end if
- if (eloff .lt. 0.995) then
- write(notexq(istrtn:istrtn+3),'(i1,f3.2)')0,eloff
- else if (eloff .lt. 9.995) then
- write(notexq(istrtn:istrtn+3),'(f4.2)')eloff
- else
- write(notexq(istrtn:istrtn+4),'(f5.2)')eloff
- lnote = lnote+1
- end if
- call notefq(noteq,lnoten,nlnum,ncmid)
- notexq = notexq(1:lnote)//'}'//noteq(1:lnoten)
- lnote = lnote+1+lnoten
- if (ntupv .lt. 10) then
- write(notexq(lnote+1:lnote+1),'(i1)')ntupv
- lnote = lnote+1
- else
- notexq = notexq(1:lnote)//'{'
- write(notexq(lnote+2:lnote+3),'(i2)')ntupv
- notexq = notexq(1:lnote+3)//'}'
- lnote = lnote+4
- end if
- end if
- return
- end
- subroutine read10(string,lastchar)
- parameter (maxblks=9600)
- character*131072 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- character*(*) string
- character*128 lnholdq
- logical lastchar
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- if (.not.mplay) then
- if (ilbuf .gt. nlbuf) go to 999
- call getbuf(string)
- return
-999 lastchar = .true.
- return
- else
-c
-c Play a macro. Set pointer to first character needed in buffer
-c
- if (ilmac .eq. il1mac(macnum)) then
-c
-c Getting first line of macro
-c
- ip1 = ip1mac(macnum)
- iplmac = ip1-ic1mac(macnum)
- else if (ilmac .le. il2mac(macnum)) then
-c
-c Beyond first line of macro. Advance line-start pointer.
-c
- iplmac = iplmac+lbuf(ilmac-1)
- ip1 = iplmac+1
- else
-c
-c Beyond last line of macro. Terminate it!
-c
- mplay = .false.
- endmac = .true.
- return
- end if
- if (ilmac .eq. il2mac(macnum)) then
-c
-c Getting last line of macro.
-c
- ip2 = ip2mac(macnum)
- else
-c
-c Getting line before last line of macro.
-c
- ip2 = iplmac+lbuf(ilmac)
- end if
- if (ip2 .ge. ip1) then
- string = bufq(ip1:ip2)
- else
-c
-c Kluge for when macro start is on a line by itself
-c
- string = ' '
- end if
- ilmac = ilmac+1
- return
- end if
- end
- function readin(lineq,iccount,nline)
-c
-c Reads a piece of setup data from file lineq, gets a new lineq from
-c file 10 (jobname.pmx) and increments nline if needed, passes over
-c comment lines
-c
- character*128 lineq
- character*1 durq,chax
-4 if (iccount .eq. 128) then
-1 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 1
- iccount = 0
- end if
- iccount = iccount+1
-c
-c Find next non-blank or end of line
-c
- do 2 iccount = iccount , 127
- if (lineq(iccount:iccount) .ne. ' ') go to 3
-2 continue
-c
-c If here, need to get a new line
-c
- iccount = 128
- go to 4
-3 continue
-c
-c iccount now points to start of number to read
-c
- i1 = iccount
-5 call getchar(lineq,iccount,durq)
-c
-c Remember that getchar increments iccount, then reads a character.
-c
- if (index('0123456789.-',durq) .gt. 0) go to 5
- i2 = iccount-1
- if (i2 .lt. i1) then
- print*,'Found "'//durq//'" instead of number'
- call stop1()
- end if
- icf = i2-i1+49
- read(lineq(i1:i2),'(f'//chax(icf)//'.0)')readin
- return
- end
- subroutine readmeter(lineq,iccount,mtrnum,mtrden)
- character*128 lineq
- character*1 durq,chax
- if (index(lineq(iccount+1:iccount+3),'/') .eq. 0) then
-c
-c No slashes, so use old method
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. '-') then
-c
-c Negative numerator is used only to printed; signals vertical slash
-c
- call getchar(lineq,iccount,durq)
- mtrnum = -(ichar(durq)-48)
- else if (durq .eq. 'o') then
-c
-c Numerator is EXACTLY 1
-c
- mtrnum = 1
- else
- mtrnum = ichar(durq)-48
- if (mtrnum .eq. 1) then
-c
-c Numerator is >9
-c
- call getchar(lineq,iccount,durq)
- mtrnum = 10+ichar(durq)-48
- end if
- end if
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'o') then
- mtrden = 1
- else
- mtrden = ichar(durq)-48
- if (mtrden .eq. 1) then
- call getchar(lineq,iccount,durq)
- mtrden = 10+ichar(durq)-48
- end if
- end if
- else
-c
-c Expect the form m[n1]/[n2]/[n3]/[n4] . Advance iccount by one from '/' or 'm'
-c
- iccount = iccount+1
- ns = index(lineq(iccount:128),'/')
- read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrnum
-c
-c Reset iccount to start of second integer
-c
- iccount = iccount+ns
-c
-c There must be either a slash or a blank at pos'n 2 or 3
-c
- ns = index(lineq(iccount:iccount+2),'/')
- if (ns .eq. 0) ns = index(lineq(iccount:iccount+2),' ')
- read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrden
-c
-c Set iccount to last character used
-c
- iccount = iccount+ns-1
- end if
- return
- end
- subroutine readnum(lineq,iccount,durq,fnum)
-c
-c This reads a number starting at position iccount. Remember that on exit,
-c getchar leaves iccount at the last character retrieved. So must only
-c call this routine *after* detecting a number or decimal.
-c On exit, durq is next character after end of number.
-c
- character*128 lineq
- character*1 durq,chax
- i1 = iccount
-1 call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .gt. 0) go to 1
- i2 = iccount-1
- if (i2 .lt. i1) then
- print*,'Found "'//durq//'" instead of number'
- call stop1()
- else if (lineq(i1:i1).eq.'.'.and.lineq(i2:i2).eq.'.') then
- i2 = i2-1
- iccount = iccount-1
- end if
- icf = i2-i1+49
- read(lineq(i1:i2),'(f'//chax(icf)//'.0)')fnum
- return
- end
- subroutine setbits(isdata,iwidbit,ishift,ivalue)
-c
-c Sets iwidbits of isdata, shifted by ishift, to ivalue
-c
- ibase = 2**iwidbit-1
- isdata = iand(not(ishft(ibase,ishift)),isdata)
- isdata = ior(isdata,ishft(ivalue,ishift))
- return
- end
- subroutine setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1)
-c
-c The MEAN SQUARE slope algorithm
-c
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,
- * isfig
- real*4 xelsk(24)
- integer ipb(24)
- ibc = ibmcnt(ivx)
- sumxx = 0.
- sumxy = 0.
- do 2 inb = 1 , nnb
- sumxx = sumxx+xelsk(inb)**2
- sumxy = sumxy+xelsk(inb)*nolev(ivx,ipb(inb))
-2 continue
- delta = nnb*sumxx-sumx*sumx
- em = (nnb*sumxy-sumx*sumy)/delta
- islope = nint(0.5*em*slfac)
- if (iabs(islope) .gt. 9) islope = isign(9,islope)
- beta = (sumy-islope/slfac*sumx)/nnb
- nolev1 = nint(beta)
-c
-c Check if any stems are too short
-c
- smin = 100.
- iul = -1
- if (ulq(ivx,ibc) .eq. 'u') iul = 1
- do 4 inb = 1 , nnb
- ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac
- ynote = nolev(ivx,ipb(inb))
- smin = min(smin,iul*(ybeam-ynote))
-4 continue
- if (smin .lt. stemmin) then
- deficit = stemmin-smin
- nolev1 = nint(nolev1+iul*deficit)
- end if
- return
- end
- subroutine setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,
- * ivx,nline)
- character*1 charq,durq
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac,btest
- character*128 lnholdq,lineq
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
-c
-c Macro action
-c
- call g1etchar(lineq,iccount,charq)
- if (charq.eq.'S' .and. ivx.ne.1) then
- print*
- print*
- print*,'*********WARNING*********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"MS..." only put in parts by scor2prt if in voice #1!')
- end if
- if (index('RSP ',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "M" (macro)!')
- call stop1()
- else if (charq .ne. ' ') then
-c
-c Record or playback a macro. Get the number of the macro.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must input number after "MR","MP", or "MS"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- macnum = nint(fnum)
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Macro number must be followed by a blank!')
- call stop1()
- end if
- if (index('RS',charq ).gt. 0) then
-c
-c Record or save a macro
-c
- if (macnum.lt.1 .or. macnum.gt.20) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Macro number not in range 1-20!')
- call stop1()
- end if
- macuse = ibset(macuse,macnum)
- if (charq .eq. 'R') then
- call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
- else if (charq .eq. 'S') then
-c
-c Save (Record but don't activate)
-c
-1 call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
- if (mrecord) then
- call getbuf(lineq)
- nline = nline+1
- iccount = 0
- go to 1
- end if
- iccount = iccount+ndxm+1
- end if
- else
-c
-c Playback the macro
-c
- if (.not.btest(macuse,macnum)) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Cannot play a macro that has not been recorded!')
- call stop1()
- end if
- icchold = iccount
- lnholdq = lineq
- iccount = 128
- mplay = .true.
- ilmac = il1mac(macnum)
- end if
- end if
- return
- end
- subroutine setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
-c
-c Sets last 2 args depending on 1st 2, (logical) num, denom.
-c ibmtyp = 1, 2, or 3 defines set of masks for beam groupings.
-c 1: all duple meters
-c 2: triple w/ denom=4, subdivide in groups of 2 8ths
-c 3: triple w/ denom=8, subdivide in groups of 3 8ths
-c Note that lenbar is set at top or when 'm' symbol is read in getnote
-c
- if (mtrdenl .eq. 4) then
- if (mod(mtrnuml,3) .eq. 0) then
- ibmtyp = 2
- ibmrep = mtrnuml/3
- else
- ibmtyp = 1
- ibmrep = mtrnuml/2
- end if
- else if (mtrdenl .eq. 2) then
- ibmtyp = 1
- if (mtrnuml .eq. 3) then
- ibmrep = 3
- else
- ibmrep = 2*mtrnuml/mtrdenl
- end if
- else if (mtrdenl.eq.8 .and. (mtrnuml.eq.8.or.mtrnuml.eq.4)) then
-c
-c Added 170726
-c
- ibmtyp = 1
- ibmrep = mtrnuml/4
- else
-c
-c Assumes mtrdenl=8 and 3/8, 6/8, 9/8, or 12/8
-c
- ibmtyp = 3
- ibmrep = mtrnuml/3
- end if
-c
-c Reset so we don't keep writing new meters
-c
- mtrnuml = 0
-c
-c Prevent ibmrep=0. Needed for odd bars, e.g. 1/8, where beams don't matter
-c
- ibmrep = max(ibmrep,1)
- return
- end
- subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest)
-c
-c The outer combo algorithm
-c
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,btest,
- * isfig,vxtup,l1ng,l2ng,bar1syst,drawbm
- common /comeskz2/ eskz2(nm,200)
- real*4 slope(800),xelsk(24)
- integer ipb(24)
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xels11(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /combmh/ bmhgt,clefend
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtol/ tol
- ibc = ibmcnt(ivx)
- nxtinbm(ivx) = 0
- n1 = ipl2(ivx,ibm1(ivx,ibc))
-c
-c Initialize counters used in this subroutine, and then later during actual
-c beam drawing, to count later segments of single-slope beam groups
-c
- nssb(ivx) = 0
- issb(ivx) = 0
-c
-c Set flag for xtup beam starting with rest (no others can start with rest)
-c
- if (btest(irest(ivx,ipo(n1)),0)) ixrest = 1
-c
-c Figure how many elemskips to each note. Use the list, counting only non-rests.
-c
- eskz0 = eskz(ivx,ibm1(ivx,ibc))
- nnb = 0
- sumx = 0.
- sumy = 0.
- ipxt1 = 0
- iplast = ibm2(ivx,ibc)
- do 2 ip = ibm1(ivx,ibc) , iplast
- if (.not.btest(irest(ivx,ip),0)) then
- nnb = nnb+1
- ipb(nnb) = ip
- xelsk(nnb) = eskz(ivx,ip)-eskz0
- sumx = sumx+xelsk(nnb)
- sumy = sumy+nolev(ivx,ipb(nnb))
- if (btest(nacc(ivx,ip),21)) then
-c
-c This is the starting note of later segment of single-slope beam group
-c Temporarily store ip here.
-c
- nssb(ivx) = nssb(ivx)+1
- lev1ssb(ivx,nssb(ivx)) = nnb
- end if
- end if
-c
-c New xtup stuff here. Final object is to get distance from start of xtup
-c to number. xtinbm counts xtups in this beam only. mtupv is the printed
-c number. ntupv is number of notes in xtup, and is only used to get
-c eloff, the distance from start of xtup to the number.
-c
- if (btest(nacc(ivx,ip),18)) ndoub = ndoub+1
- if (ipxt1.eq.0 .and. nodur(ivx,ip).eq.0) then
-c
-c Xtup is starting here
-c
- nxtinbm(ivx) = nxtinbm(ivx)+1
- ipxt1 = ip
- if (btest(nacc(ivx,ip),18)) then
- ndoub = 1
- else
- ndoub = 0
- end if
- else if (ipxt1.gt.0 .and. nodur(ivx,ip).gt.0) then
-c
-c Xtup ends here. Set total number of notes in xtup.
-c
- ntupv(ivx,nxtinbm(ivx)) = ip+1-ipxt1
-c
-c Set printed number for embedded xtup.
-c
- mtupv(ivx,nxtinbm(ivx)) = ntupv(ivx,nxtinbm(ivx))+ndoub
-c
-c Middle note of xtup if ntupv odd, note to left of gap if even.
-c
- ipxtmid = (ip+ipxt1)/2
- eloff(ivx,nxtinbm(ivx)) = eskz2(ivx,ipxtmid)-eskz2(ivx,ipxt1)
- if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0)
- * eloff(ivx,nxtinbm(ivx)) = eloff(ivx,nxtinbm(ivx))+
- * .5*(eskz2(ivx,ipxtmid+1)-eskz2(ivx,ipxtmid))
- ipxt1 = 0
- end if
-2 continue
-c
-c Reset nxtinbm for use as counter as #'s are posted by putxtn(..)
-c
- nxtinbm(ivx) = 0
- smed = 0.
-c if (.not.btest(islur(ivx,ipb(1)),2)) then
- if (.not.btest(islur(ivx,ipb(1)),2) .and. nnb.gt.1) then
-c
-c No forced 0 slope
-c
-c if (nnb .eq. 1) go to 6
- nsc = 0
- do 5 inb = 1 , nnb-1
- do 5 jnb = inb+1 , nnb
- nsc = nsc+1
- slope(nsc) = (nolev(ivx,ipb(jnb))-nolev(ivx,ipb(inb)))/
- * (xelsk(jnb)-xelsk(inb))
- if (abs(slope(nsc)) .lt. 1.e-4) then
- nsc = nsc+1
- slope(nsc) = slope(nsc-1)
- nsc = nsc+1
- slope(nsc) = slope(nsc-1)
- end if
-5 continue
- if (nsc .eq. 1) then
- smed = slope(1)
- go to 6
- end if
- nscmid = nsc/2+1
- do 7 i = 1 , nscmid
- do 7 j = i+1 , nsc
- if (slope(j) .lt. slope(i)) then
- t = slope(j)
- slope(j) = slope(i)
- slope(i) = t
- end if
-7 continue
- smed = slope(nscmid)
- if (nsc .eq. 2*(nsc/2)) then
-c
-c Even number of slopes in the list, so median is ambiguous
-c
- if (abs(slope(nscmid-1)) .lt. abs(slope(nscmid))-tol) then
-c
-c Lower-numbered one is truly less in absolute value, so use it
-c
- smed=slope(nscmid-1)
- else if (abs(slope(nscmid-1)+slope(nscmid)) .lt. tol) then
-c
-c Two slopes are effectively equal. Take the one with sign of the average
-c
- sum = 0.
- do 1 i = 1 , nsc
- sum = sum+slope(i)
-1 continue
- smed = sign(smed,sum)
- end if
- end if
-6 continue
- islope(ivx) = nint(0.5*smed*slfac)
- if (iabs(islope(ivx)) .gt. 9)
- * islope(ivx) = isign(9,islope(ivx))
- else
-c
-c Forced horizontal beam
-c
- islope(ivx) = 0
- end if
- beta = (sumy-islope(ivx)/slfac*sumx)/nnb
-c
-c If ixrest>0, this is a virtual nolev1 at location of rest. Will first use
-c as is for placing xtup number and/or bracket, then reset it for start of
-c actual beam
-c
- nolev1(ivx) = nint(beta)
-c
-c Check if any stems are too short
-c
- smin = 100.
- iul = -1
- if (ulq(ivx,ibc) .eq. 'u') iul = 1
- ssq = 0.
- syb = 0.
- yb1 = nolev1(ivx)
- * +iul*(stemlen+bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1))
- do 4 inb = 1 , nnb
- ybeam = yb1+islope(ivx)*xelsk(inb)/slfac
- * -iul*bmhgt*(iand(15,mult(ivx,ipb(inb)))-8-1)
- syb = syb+ybeam
- ynote = nolev(ivx,ipb(inb))
- off = ybeam-ynote
- if (inb .eq. 1) then
- off1 = off
- else if (inb .eq. nnb) then
- off2 = off
- end if
- ssq = ssq+off*off
- smin = min(smin,iul*off)
-4 continue
- dnolev = 0.
- if (smin .lt. stemmin) then
- deficit = stemmin-smin
- nolevo = nolev1(ivx)
- nolev1(ivx) = nint(nolev1(ivx)+iul*deficit)
- dnolev = nolev1(ivx)-nolevo
- off1 = off1+dnolev
- off2 = off2+dnolev
- end if
- ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2
- if (.not.vxtup(ivx) .and. sqrt(ssq/nnb) .gt. stemmax .and.
- * (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax)
-c * .and. .not.btest(islur(ivx,ipb(1)),2)) then
- * .and. .not.btest(islur(ivx,ipb(1)),2)
- * .and. nnb.ne.1) then
-c
-c The first check is to save trouble of putting xtup's in setbm2.
-c The penultimate check is that first and last stems aren't both excessive.
-c The last check is that a 0 slope has not been forced
-c
- call setbm2(xelsk,nnb,sumx,sumy,ipb,islope(ivx),nolev1(ivx))
- end if
-c
-c Check if beam starts or ends too high or low.
-c
- xboff = bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1)
- l1ng = iul*(nolev1(ivx)-ncmid(iv,ipb(1)))+xboff+7 .lt. 0.
- xnolev2 = nolev1(ivx)+islope(ivx)/slfac*xelsk(nnb)
- l2ng = iul*(xnolev2-ncmid(iv,ipb(nnb)))+xboff+7 .lt. 0
- if (l1ng .or. l2ng) then
-c
-c Need to correct start or stop, also slope
-c
- if (l1ng) then
- nolev1(ivx) = nint(ncmid(iv,ipb(1))-(7.+xboff)*iul)
- end if
- if (l2ng) then
- xnolev2 = nint(ncmid(iv,ipb(nnb))-(7.+xboff)*iul)
- end if
-c
-c Since one or the other end has changed, need to change slope
-c
-c if (.not.btest(islur(ivx,ipb(1)),2))
- if (.not.btest(islur(ivx,ipb(1)),2) .and. nnb.ne.1)
- * islope(ivx) = nint(slfac*(xnolev2-nolev1(ivx))/xelsk(nnb))
- end if
- if (nssb(ivx) .gt. 0) then
-c
-c This is a single-slope beam group. Store start heights for later segs.
-c
- do 3 issbs = 1 , nssb(ivx)
- lev1ssb(ivx,issbs) = nolev1(ivx)+islope(ivx)/slfac*
- * xelsk(lev1ssb(ivx,issbs))
-3 continue
- end if
- return
- end
- subroutine sortpoe(nsyst,poe,ipoe)
- parameter (nks=125)
- real*4 poe(nks)
- integer*4 ipoe(nks)
-c
-c Initialize ipoe:
-c
- do 3 iord = 1 , nsyst
- ipoe(iord) = iord
-3 continue
-c
-c Construct ipoe vector with pairwise interchanges. When done, ipoe(1) will
-c be index of smallest poe, and ipoe(nsyst) will be index of biggest poe.
-c
- do 4 io1 = 1 , nsyst-1
- do 5 io2 = io1+1 , nsyst
- if (poe(ipoe(io1)) .gt. poe(ipoe(io2))) then
-c
-c Interchange the indices
-c
- itemp = ipoe(io1)
- ipoe(io1) = ipoe(io2)
- ipoe(io2) = itemp
- end if
-5 continue
-4 continue
- return
- end
- subroutine spsslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3,
- * isdat4,nsdat,notcrd,nolev,starter)
- parameter (nm=24)
-c
-c Reads in slur data. Record all h/v-shifts for non-chords, user-specified
-c ones for chords.
-c 5/26/02 This subr is called ONLY for postscript slurs.
-c
-c See subroutine doslur for bit values in isdat1,2,3
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202)
- logical notcrd,btest
- character*128 lineq
- character*1 durq,dumq,starter
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical upslur,fontslur,WrotePsslurDefaults
-c
-c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve
-c
- numint = 0
- ivoff = 0
- ihoff = 0
- nsdat = nsdat+1
- if (starter.eq.'{' .or. starter.eq.'}')
- * isdat2(nsdat)=ibset(isdat2(nsdat),3)
- call setbits(isdat1(nsdat),5,13,iv)
- call setbits(isdat1(nsdat),1,12,kv-1)
- call setbits(isdat1(nsdat),8,3,ip)
- isdat3(nsdat) = 0
- isdat4(nsdat) = 0
- ilb12 = 0 ! flag for tweaks of 1st or 2nd (0|1) seg of linebreak slur
-c
-c Get ID code
-c
- call getchar(lineq,iccount,durq)
-c if (index('uldtb+-hfnHps ',durq) .gt. 0) then
- if (index('uldtb+-hfnHpsv ',durq) .gt. 0) then
-c
-c Null id. Note for ps slurs, 'H' cannot be an ID
-c
- iccount = iccount-1
- if (lineq(iccount:iccount) .eq. 't') then
- idcode = 1
- else
- idcode = 32
- end if
- else
-c
-c Set explicit idcode
-c
- idcode = ichar(durq)
- if (lineq(iccount-1:iccount-1) .eq. 't') then
-c
-c Make t[ID] look like s[ID]t
-c
- isdat2(nsdat) = ibset(isdat2(nsdat),3)
- end if
- if (lineq(iccount+1:iccount+1).eq.'x') then
-c
-c Flag for 2-voice, indexed slurs
-c
- iccount = iccount+1
- call setbits(isdat1(nsdat),1,1,1)
- end if
- end if
- call setbits(isdat1(nsdat),7,19,idcode)
-c
-c Set start/stop: look thru list from end for same idcode,iv,kv
-c
- do 2 isdat = nsdat-1 , 1 , -1
- if (idcode .eq. igetbits(isdat1(isdat),7,19) .and.
- * iv .eq. igetbits(isdat1(isdat),5,13) .and.
-c * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then
- * (kv-1 .eq. igetbits(isdat1(isdat),1,12)
- * .or. btest(isdat1(isdat),1))) then
-c
-c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0.
-c
- if (btest(isdat1(isdat),11)) go to 3
-c
-c Found slur is a turnoff, so new one is a turnon. Jump down to set bit
-c
- go to 4
- end if
-2 continue
-c
-c If here, this is turnon.
-c
-4 continue
- isdat1(nsdat) = ibset(isdat1(nsdat),11)
-3 continue
-c
-c Now done with initial turnon- or turnoff-specifics.
-c
- if (nint(SlurCurve).ne.0 .and. btest(isdat1(nsdat),11)) then
-c
-c There's a default curvature tweak
-c
- icurv1 = nint(SlurCurve)+3
- if (icurv1 .eq. 2) icurv1 = 1
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- end if
-c
-c Loop for rest of input
-c
-1 call getchar(lineq,iccount,durq)
- if (index('uld',durq) .gt. 0) then
-c
-c Force direction
-c
- isdat1(nsdat) = ibset(isdat1(nsdat),26)
- if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27)
- go to 1
- else if (index('+-',durq) .gt. 0) then
- numint = numint+1
- if (numint .eq. 1) then
-c
-c Vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
- ivoff = nint(fnum)
- if (durq .eq. '-') ivoff = -ivoff
- else if (numint .eq. 2) then
-c
-c Horizontal offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
-c
-c fnum is abs(hshift), must be 0 to 6.3
-c
- ihoff = fnum*10 + .5
- if (durq .eq. '-') ihoff = -ihoff
-c
-c Later will set bits to 1...127 to represent -6.3,...+6.3
-c
- else
-c
-c Must be the 3rd signed integer, so it's a curve specification
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- icurv1 = nint(fnum)
- if (durq .eq. '-') icurv1 = -icurv1
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- if (dumq .ne. ':') then
-c
-c Back up the pointer and loop for more input
-c
- iccount = iccount-1
- else
-c
-c Expect two single digits as parameters for curve
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),1)
- call setbits(isdat3(nsdat),3,8,
- * ichar(lineq(iccount+1:iccount+1))-48)
- call setbits(isdat3(nsdat),3,11,
- * ichar(lineq(iccount+2:iccount+2))-48)
- iccount = iccount+2
- end if
- end if
- go to 1
- else if (durq .eq. 't') then
- isdat2(nsdat) = ibset(isdat2(nsdat),3)
- go to 1
- else if (durq .eq. 'b') then
- isdat2(nsdat) = ibset(isdat2(nsdat),4)
- go to 1
- else if (durq .eq. 's') then
-c
-c Endpoint tweaks for linebreak slurs.
-c
- call getchar(lineq,iccount,durq) ! Must be +|-
-c
-c Next is vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (durq .eq. '-') fnum=-fnum
- call setbits(isdat4(nsdat),6,ilb12*16,nint(fnum)+32)
- if (index('+-',dumq) .gt. 0) then
-c
-c Also a horizontal offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (dumq .eq. '-') fnum=-fnum
- call setbits(isdat4(nsdat),7,ilb12*16+6,nint(10*fnum)+64)
- end if
- iccount = iccount-1
- ilb12 = 1
- go to 1
- else if (index('fnhH',durq).gt.0) then
-c
-c Special ps slur curvatures.
-c Translate to old \midslur args (1,4,5,6)
-c
- icurv1 = index('fnxhH',durq)
- if (icurv1 .eq. 5) then
-c
-c check for 2nd H
-c
- if (lineq(iccount+1:iccount+1) .eq. 'H') then
- iccount = iccount+1
- icurv1 = 6
- end if
- end if
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- go to 1
- else if (durq .eq. 'p') then ! Local adjustment
- call getchar(lineq,iccount,durq) ! +|-
- call getchar(lineq,iccount,dumq) ! s|t
-c 26 \sluradjust (p+s)
-c 27 \nosluradjust (p-s)
-c 28 \tieadjust (p+t)
-c 29 \notieadjust (p-t)
- if (durq .eq. '+') then
- if (dumq .eq. 's') then
- isdat2(nsdat) = ibset(isdat2(nsdat),26)
- else
- isdat2(nsdat) = ibset(isdat2(nsdat),28)
- end if
- else
- if (dumq .eq. 's') then
- isdat2(nsdat) = ibset(isdat2(nsdat),27)
- else
- isdat2(nsdat) = ibset(isdat2(nsdat),29)
- end if
- end if
- go to 1
- else if (durq .eq. 'v') then ! Stem slur
- isdat1(nsdat) = ibset(isdat1(nsdat),2)
- go to 1
- end if
-c
-c Record shifts
-c
- call setbits(isdat2(nsdat),6, 6,ivoff+32)
- call setbits(isdat2(nsdat),7,12,ihoff+64)
-c
-c Record chord flag, note level, notehead shift
-c
- if (notcrd) then
- call setbits(isdat2(nsdat),7,19,nolev)
- else
- nolevc = igetbits(icrdat(ncrd),7,12)
- call setbits(isdat2(nsdat),7,19,nolevc)
- isdat2(nsdat) = ibset(isdat2(nsdat),0)
- call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23))
- end if
- return
- end
- subroutine sslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3,
- * nsdat,notcrd,nolev,starter)
- parameter (nm=24)
-c
-c Reads in slur data. Record all h/v-shifts for non-chords, user-specified
-c ones for chords.
-c 5/26/02 now only for non-postscript slurs, use spsslur() for postscript
-c
-c See subroutine doslur for bit values in isdat1,2,3
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- integer*4 isdat1(202),isdat2(202),isdat3(202)
- logical notcrd,btest
- character*128 lineq
- character*1 durq,dumq,starter
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical upslur,fontslur,WrotePsslurDefaults
-c
-c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve
-c
- numint = 0
- ivoff = 0
- ihoff = 0
- nsdat = nsdat+1
- if (starter.eq.'{' .or. starter.eq.'}')
- * isdat2(nsdat)=ibset(isdat2(nsdat),3)
- call setbits(isdat1(nsdat),5,13,iv)
- call setbits(isdat1(nsdat),1,12,kv-1)
- call setbits(isdat1(nsdat),8,3,ip)
- isdat3(nsdat) = 0
-c
-c Get id letter
-c
- if (lineq(iccount:iccount) .eq. 't') then
-c
-c Old-style t-slur. Use special idcode = 1
-c
- idcode = 1
- else
- call getchar(lineq,iccount,durq)
- if (index('uldtb+-hf ',durq) .gt. 0) then
-c
-c Null id
-c
- idcode = 32
- iccount = iccount-1
- else if (durq.eq.'H') then
-c
-c Postscript slur, cannot use 'H' as code, must check for 2nd 'H'
-c
- idcode = 32
- iccount = iccount-1
-c
-c There may be another "H", but no need to deal with it yet
-c
- else
-c
-c Set explicit idcode
-c
- idcode = ichar(durq)
- end if
- end if
- call setbits(isdat1(nsdat),7,19,idcode)
-c
-c Set start/stop: look thru list from end for same idcode,iv,kv
-c
- do 2 isdat = nsdat-1 , 1 , -1
- if (idcode .eq. igetbits(isdat1(isdat),7,19) .and.
- * iv .eq. igetbits(isdat1(isdat),5,13) .and.
- * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then
-c
-c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0.
-c
- if (btest(isdat1(isdat),11)) go to 3
-c
-c Found slur is a turnoff, so new one is a turnon. Jump down to set bit
-c
- go to 4
- end if
-2 continue
-c
-c If here, this is turnon.
-c
-4 continue
- isdat1(nsdat) = ibset(isdat1(nsdat),11)
-3 continue
-c
-c Now done with initial turnon- or turnoff-specifics. Loop for rest of input
-c
-1 call getchar(lineq,iccount,durq)
- if (index('uld',durq) .gt. 0) then
-c
-c Force direction
-c
- isdat1(nsdat) = ibset(isdat1(nsdat),26)
- if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27)
- go to 1
- else if (index('+-',durq) .gt. 0) then
- numint = numint+1
- if (numint .eq. 1) then
-c
-c Vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
- ivoff = nint(fnum)
- if (durq .eq. '-') ivoff = -ivoff
- else if (numint .eq. 2) then
-c
-c Horizontal offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
-c
-c fnum is abs(hshift), must be 0 to 6.3
-c
- ihoff = fnum*10 + .5
- if (durq .eq. '-') ihoff = -ihoff
-c
-c Later will set bits to 1...127 to represent -6.3,...+6.3
-c
- else
-c
-c Must be the 3rd signed integer, so it's a curve specification
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- icurv1 = nint(fnum)
- if (durq .eq. '-') icurv1 = -icurv1
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- if (dumq .ne. ':') then
-c
-c Back up the pointer and loop for more input
-c
- iccount = iccount-1
- else
-c
-c Expect two single digits as parameters for curve
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),1)
- call setbits(isdat3(nsdat),3,8,
- * ichar(lineq(iccount+1:iccount+1))-48)
- call setbits(isdat3(nsdat),3,11,
- * ichar(lineq(iccount+2:iccount+2))-48)
- iccount = iccount+2
- end if
- end if
- go to 1
- else if (durq .eq. 't') then
- isdat2(nsdat) = ibset(isdat2(nsdat),3)
- go to 1
- else if (durq .eq. 'b') then
- isdat2(nsdat) = ibset(isdat2(nsdat),4)
- go to 1
- else if (index('fhH',durq) .gt. 0) then
-c
-c Special ps slur curvatures. Translate to old \midslur args (1,4,5,6)
-c
- icurv1 = 2+index('fhH',durq)
- if (icurv1 .eq. 3) then
- icurv1 = 1
- else if (icurv1 .eq. 5) then
-c
-c check for 2nd H
-c
- if (lineq(iccount+1:iccount+1) .eq. 'H') then
- iccount = iccount+1
- icurv1 = 6
- end if
- end if
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
-c
-c Must change sign if downslur, but cannot do it now since we don't know
-c slur direction for sure.
-c
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- go to 1
- end if
-c
-c Record shifts
-c
- call setbits(isdat2(nsdat),6, 6,ivoff+32)
- call setbits(isdat2(nsdat),7,12,ihoff+64)
-c
-c Record chord flag, note level, notehead shift
-c
- if (notcrd) then
- call setbits(isdat2(nsdat),7,19,nolev)
- else
- nolevc = igetbits(icrdat(ncrd),7,12)
- call setbits(isdat2(nsdat),7,19,nolevc)
- isdat2(nsdat) = ibset(isdat2(nsdat),0)
- call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23))
- end if
- return
- end
- subroutine stop1()
- call exit(1)
- end
- subroutine topfile(basenameq,lbase,nv,clefq,noinst,musicsize,
- * xinstf1,mtrnmp,mtrdnp,vshrink,fbar,fontslur)
- parameter (nm=24)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink,fontslur
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig,
- * lnam(nm),inameq(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- character*79 inameq
- character*44 basenameq
- character*24 fmtq
- character*5 fbarq
- character*1 clefq(nm),sq,chax,clefqiv
- common /comstart/ facmtr
- logical vshrink,lowdot,rename
- logical novshrinktop,cstuplet
- common /comnvst/ novshrinktop,cstuplet
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /comsize/ isize(nm)
- common /comis4bignv/ is4bignv,AIset
- logical is4bignv,AIset
- common /comc8flag/ c8flag(nm)
- logical c8flag
- sq = chax(92)
- vshrink = xinstf1.gt.20. .and. .not.novshrinktop
- if (vshrink) then
- xinsnow = 10.
- else
- xinsnow = xinstf1
- end if
- if (.not.islast) return
-c
-c Initialize octave treble clef tracker
-c
- do 6 im = 1 , nm
- c8flag(im) = .false.
-6 continue
- write(11,'(a)')'%%%%%%%%%%%%%%%%%'
- write(11,'(a)')'%'
- write(11,'(a)')'% '//basenameq(1:lbase)//'.tex'
- write(11,'(a)')'%'
- write(11,'(a)')'%%%%%%%%%%%%%%%%'
- write(11,'(a)')sq//'input musixtex'
- write(11,'(a)')sq//'input pmx'
- write(11,'(a)')
- * sq//'setmaxslurs{24}'//sq//'setmaxinstruments{24}%'
- if (.not.fontslur) write(11,'(a)')sq//'input musixps'
-c
-c Need to input musixmad to permit more slurs.
-c
- if (musicsize .eq. 20) then
- write(11,'(a)')sq//'normalmusicsize%'
- else if (musicsize .eq. 16) then
- write(11,'(a)')sq//'smallmusicsize%'
- else if (musicsize .eq. 24) then
- write(11,'(a)')sq//'largemusicsize%'
-c
-c Eliminate, per Tennent's analysis and musixtex changes since first input
-c
-c write(11,'(a)')sq//'def'//sq//'meterfont{'//sq//
-c * 'meterlargefont}%'
- else if (musicsize .eq. 29) then
- write(11,'(a)')sq//'Largemusicsize%'
-c write(11,'(a)')sq//'def'//sq//'meterfont{'//sq//
-c * 'meterLargefont}%'
- end if
-c
-c Set sizes. Have sizes per staff in isize(.) and noinst per staff in
-c nsperi(.)
-c
-c 130324
-c iiv = 1
- do 5 iinst = 1 , noinst
-c if (isize(iiv) .eq. 1) then
- if (isize(iinst) .eq. 1) then
- if(iinst.le.9) then
- write(11,'(a8,i1,a)')
- * sq//'setsize',iinst,sq//'smallvalue%'
- else
- write(11,'(a9,i2,a)')
- * sq//'setsize{',iinst,'}'//sq//'smallvalue%'
- end if
-c else if (isize(iiv) .eq. 2) then
- else if (isize(iinst) .eq. 2) then
- if(iinst.le.9) then
- write(11,'(a8,i1,a)')
- * sq//'setsize',iinst,sq//'tinyvalue%'
- else
- write(11,'(a9,i2,a)')
- * sq//'setsize{',iinst,'}'//sq//'tinyvalue%'
- end if
- end if
-c iiv = iiv+nsperi(iinst)
-5 continue
- write(fbarq,'(f5.3)')fbar
- write(11,'(a)')sq//'nopagenumbers'
- write(11,'(a)')sq//'tracingstats=2'//sq//'relax'
- write(11,'(a7,i3,a2)')sq//'hsize=',nint(widthpt),'pt'
- write(11,'(a6,i'//chax(49+int(log10(height+.1)))//',a2)')
- * sq//'vsize',int(height+.1),'pt'
- if (abs(hoffpt) .gt. 0.1) then
- if (hoffpt .le. -10.) then
- write(11,'(a8,i3,a2)')sq//'hoffset',nint(hoffpt),'pt'
- else if (hoffpt .lt. 0.) then
- write(11,'(a8,i2,a2)')sq//'hoffset',nint(hoffpt),'pt'
- else if (hoffpt .lt. 10.) then
- write(11,'(a8,i1,a2)')sq//'hoffset',nint(hoffpt),'pt'
- else
- write(11,'(a8,i2,a2)')sq//'hoffset',nint(hoffpt),'pt'
- end if
- end if
- if (abs(voffpt) .gt. 0.1) then
- if (voffpt .le. -10.) then
- write(11,'(a8,i3,a2)')sq//'voffset',nint(voffpt),'pt'
- else if (voffpt .lt. 0.) then
- write(11,'(a8,i2,a2)')sq//'voffset',nint(voffpt),'pt'
- else if (voffpt .lt. 10.) then
- write(11,'(a8,i1,a2)')sq//'voffset',nint(voffpt),'pt'
- else
- write(11,'(a8,i2,a2)')sq//'voffset',nint(voffpt),'pt'
- end if
- end if
-c
-c The default raisebarno=3.5 internote, set in pmx.tex. Increase to 4.5 if
-c 3 sharps and treble clef, to avoid vertical clash with top space g#
-c
- if (isig.eq.3 .and. clefq(nv).eq.'t') write(11,'(a)')
- * sq//'def'//sq//'raisebarno{4.5'//sq//'internote}'
- if (noinst .lt. 10) then
- write(11,'(a19,i1,a1)')sq//'def'//sq//'nbinstruments{',
- * noinst,'}'
- else
- write(11,'(a19,i2,a1)')sq//'def'//sq//'nbinstruments{',
- * noinst,'}'
- end if
- iv = 0
- do 1 iinst = 1 , noinst
- nstaves = nsperi(iinst)
- if (iinst .lt. 10) then
- write(11,'(a)')sq//'setstaffs'//chax(48+iinst)
- * //chax(48+nstaves)
- else
- write(11,'(a11,i2,a)')sq//'setstaffs{',iinst,'}'
- * //chax(48+nstaves)
- end if
- iv = iv+1
- clefqiv = clefq(iv)
- if (clefqiv.eq.'8') then
- clefqiv='t'
- iTransAmt(instno(iv)) = 7+iTransAmt(instno(iv))
- c8flag(iv) = .true.
- end if
- if (nstaves .eq. 1) then
- fmtq = chax(48+numclef(clefq(iv)))
- lfmtq = 1
- else
- fmtq = '{'//chax(48+numclef(clefq(iv)))
- lfmtq = 2
- do 2 k = 2 , nstaves
- iv = iv+1
- fmtq = fmtq(1:lfmtq)//chax(48+numclef(clefq(iv)))
- lfmtq = lfmtq+1
-2 continue
- fmtq = fmtq(1:lfmtq)//'}'
- lfmtq = lfmtq+1
- end if
- if (iinst .lt. 10) then
- write(11,'(a)')sq//'setclef'//chax(48+iinst)//fmtq(1:lfmtq)
- else
- write(11,'(a9,i2,a)')sq//'setclef{',iinst,'}'//fmtq(1:lfmtq)
- end if
- if (clefq(iv) .eq. '8') then
- if (iinst .lt. 10) then
- write(11,'(a)')sq//'settrebleclefsymbol'//chax(48+iinst)//
- * sq//'treblelowoct%'
- else
- write(11,'(a21,i2,a)')sq//'settrebleclefsymbol{',iinst,'}'//
- * sq//'treblelowoct%'
- end if
- c8flag(iv) = .true.
- end if
- do 3 lname = 79 , 2 , -1
- if (inameq(iinst)(lname:lname) .ne. ' ') go to 4
-3 continue
-4 continue
- lnam(iinst) = lname
- if (iinst .lt. 10) then
- write(11,'(a8,i1,a)')sq//'setname',iinst,
- * '{'//inameq(iinst)(1:lname)//'}'
- else
- write(11,'(a9,i2,a)')sq//'setname{',iinst,
- * '}{'//inameq(iinst)(1:lname)//'}'
- end if
-1 continue
- write(11,'(a18,i2,a2)')sq//'generalsignature{',isig,'}%'
- if (EarlyTransOn)
- * call Writesetsign(nInstTrans,iInstTrans,iTransKey,EarlyTransOn)
- call wgmeter(mtrnmp,mtrdnp)
- ipi = nint(fracindent*widthpt)
- if (ipi .lt. 10) then
- write(11,'(a11,i1,a2)')sq//'parindent ',ipi,'pt'
- else if (ipi .lt. 100) then
- write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt'
- else
- write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt'
- end if
- write(11,'(a)')sq//'elemskip1pt'//sq//'afterruleskip'
- * //fbarq//'pt'//sq//'beforeruleskip0pt'//sq//'relax'
- if (.not.vshrink) then
- if (xinstf1 .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else
- fmtq = '(a,f4.1,a)'
- end if
- facis = 1.
- if (is4bignv) facis = .95
- write(11,fmtq)sq//'stafftopmarg0pt'//sq//'staffbotmarg0pt'
- * //sq//'interstaff{',xinstf1*facis,'}'//sq//'relax'
- else
- write(11,'(a)')sq//'stafftopmarg0pt'//
- * sq//'staffbotmarg5'//sq//'Interligne'//sq//
- * 'interstaff{10}'//sq//'relax'
- end if
- if (nv.eq.1) write(11,'(a)')sq//'nostartrule'
- write(11,'(a)')sq//'readmod{'//basenameq(1:lbase)//'}'
- if (cstuplet) then
- write(11,'(a)')sq//'input tuplet'
- * //sq//'def'//sq//'xnumt#1#2#3{'//sq//'zcharnote{#2}{~}'
- * //sq//'def'//sq//'tuplettxt{'//sq//'smalltype'//sq//'it{#3}'
- * //sq//'/'//sq//'/}}%'
- write(11,'(a)')sq//'let'//sq//'ovbkt'//sq//'uptuplet'
- * //sq//'let'//sq//'unbkt'//sq//'downtuplet%'
- end if
- write(11,'(a)')sq//'startmuflex'//sq//'startpiece'//sq//
- * 'addspace'//sq//'afterruleskip%'
- return
- end
- character*1 function udfq(nolev,ncm)
-c
-c Slur directions
-c
- common /combc/ bcspec
- logical bcspec
- ntest = nolev-ncm
- if (ntest.lt.0 .or.
- * (ntest.eq.0 .and. bcspec .and. ncm.eq.23) ) then
- udfq = 'd'
- else
- udfq = 'u'
- end if
- return
- end
- character*1 function udqq(nole,ncm,isl,nvmx,ivx,nv)
-c
-c Stem direction for single notes
-c
- character*1 ulfq
- character*1 udqqq
- logical btest
- if (btest(isl,30)) then
-c
-c Absolute override
-c
- if (btest(isl,17)) then
- udqqq = 'u'
- else
- udqqq = 'l'
- end if
- else if (nvmx .eq. 1) then
-c
-c Single voice per staff, default
-c
- udqqq = ulfq(1.*nole,ncm)
- else
-c
-c Multi-voice per staff, 1st is lower, 2nd upper
-c
- if (ivx .le. nv) then
- udqqq = 'l'
- else
- udqqq = 'u'
- end if
- end if
- udqq = udqqq
- return
- end
- character*1 function ulfq(xnolev,ncm)
-c
-c Stem directions
-c
- common /combc/ bcspec
- logical bcspec
- test = xnolev-ncm
- if (test.lt.-.001 .or.
- * (test.lt..001.and.bcspec.and.ncm.eq.23) ) then
- ulfq = 'u'
- else
- ulfq = 'l'
- end if
- return
- end
- function upcaseq(chq)
- character*1 chq,upcaseq,chax
- if (ichar(chq).ge.61.and.ichar(chq).lt.122) then
- upcaseq = chax(ichar(chq)-32)
- else
- upcaseq = chq
- print*,'Warning, upcaseq was called with improper argument: '
- * //chq
- stop
- end if
- return
- end
- subroutine wgmeter(mtrnmp,mtrdnp)
-c
-c Writes meter stuff to file 11, so only called if islast=.true.
-c
- character*1 sq,chax
- if (mtrdnp .eq. 0) return
- sq=chax(92)
- if (mtrnmp.gt.0 .and. mtrnmp.le.9) then
- if (mtrdnp .lt. 10) then
- write(11,'(a25,i1,a2,i1,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- else
- write(11,'(a25,i1,a2,i2,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- end if
- else if (mtrnmp .ge. 10) then
- if (mtrdnp .lt. 10) then
- write(11,'(a25,i2,a2,i1,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- else
- write(11,'(a25,i2,a2,i2,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- end if
- else if (mtrnmp .lt. 0) then
- write(11,'(a26,i1,a2,i1,a3)')
- * sq//'generalmeter{'//sq//'meterfracS{',
- * -mtrnmp,'}{',mtrdnp,'}}%'
- else if (mtrdnp .le. 4) then
- write(11,'(a21,i1,a2)')
- * sq//'generalmeter{'//sq//'meterN',mtrdnp,'}%'
- else if (mtrdnp .eq. 5) then
- write(11,'(a)')sq//'generalmeter'//sq//'allabreve%'
- else if (mtrdnp .eq. 6) then
- write(11,'(a)')sq//'generalmeter'//sq//'meterC%'
- else if (mtrdnp .eq. 7) then
- write(11,'(a)')sq//'generalmeter'//sq//'meterIIIS%'
- end if
- return
- end
- subroutine writemidi(jobname,ljob)
- parameter(nm=24,mv=24576)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- character*1 byteq(4),char,chax
- character*10 tempoq,instq
- character*44 jobname
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
- common /comevent/ miditime,lasttime
- logical mmacrec,gottempo
- common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
- * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60),
- * mmacrec,gottempo
- character*79 inameq
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig,
- * lnam(nm),inameq(nm)
- logical rename
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
-c
-c Used to be icmm(0:nm); did midi fail when nv>16?
-c
- integer*2 iinsiv,icmm(0:15)
- character*5 versionc
- common /comver/ versionc
-c
-c These are not consecutive because channel 9 is reserved for percussion.
-c
- data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/
-c
-c Write Header
-c
- write(51,'(a,$)')'MThd'//char(0)//char(0)//char(0)//char(6)
- * //char(0)//char(1)//char(0)//char(numchan+1)//char(0)//char(240)
- if (debugmidi)
- * write(52,'(a6,10Z4)')'"MThd"',0,0,0,6,
- * 0,1,0,numchan+1,0,240
-c
-c Write the "conductor" track, for keys, meter, and tempos
-c Get the number of bytes in the conductor event stream
-c
- ndata = 1+imidi(numchan)-msecstrt(numchan,nmidsec)
- do 15 isec = 1 , nmidsec-1
- ndata = ndata+1+msecend(numchan,isec)-msecstrt(numchan,isec)
-15 continue
-c ib1 = (4+ljob+26+ndata+4)/256
-c ib0 = 4+ljob+26+ndata+4-256*ib1
- ib1 = (4+ljob+27+ndata+4)/256
- ib0 = 4+ljob+27+ndata+4-256*ib1
- write(51,'(a,$)')'MTrk'//char(0)//char(0)//char(ib1)//char(ib0)
-c
-c Text header
-c
-c * //char(0)//char(255)//char(1)//char(ljob+26)
- * //char(0)//char(255)//char(1)//char(ljob+27)
- if (debugmidi)
- * write(52,'(a6,8z4)')'"MTrk"',0,0,ib1,ib0,
- * 0,255,1,ljob+27
- write(51,'(a,$)')jobname(1:ljob)
- if (debugmidi) write(52,'(a)')'"'//jobname(1:ljob)//'"'
-c
-c (separate writes are needed to defeat compiler BUG!!!)
-c
-c write(51,'(a,$)')'.mid, produced by PMX 2.30'
- write(51,'(a,$)')'.mid, produced by PMX '//versionc
- if (debugmidi) write(52,'(a)')
- * '".mid, produced by PMX '//versionc//'"'
-c
-c Conductor event data: Loop over sections.
-c
- do 16 isec = 1 , nmidsec
- if (isec .lt. nmidsec) then
- mend = msecend(numchan,isec)
- else
- mend = imidi(numchan)
- end if
- do 17 i = msecstrt(numchan,isec) , mend
- write(51,'(a,$)')char(mmidi(numchan,i))
- if (debugmidi) write(52,'(z4)')mmidi(numchan,i)
-17 continue
-16 continue
-c
-c And close out the time sig / tempo track.
-c
- write(51,'(a,$)')char(0)//char(255)//char(2*16+15)//char(0)
- if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0
-c
-c Loop over track for each voice: The following sets up iv.
-c
- iv = nv
- if (twoline(nv)) then
- kv = 2
- else
- kv = 1
- end if
-c
- do 5 icm = 0 , numchan-1
-c
-c Get the number of bytes in the data stream
-c
- ndata = 1+imidi(icm)-msecstrt(icm,nmidsec)
- do 11 isec = 1 , nmidsec-1
- ndata = ndata+1+msecend(icm,isec)-msecstrt(icm,isec)
-11 continue
-c
-c Add 3 for instrum, 4 for bal, plus 4 (for closing) to byte count,
-c
- ndata = ndata+11
-c
-c Add 4+lnam(iinsiv(iv)) if lnam>0 ,
-c
- if (lnam(iinsiv(iv)).gt.0) ndata = ndata+4+lnam(iinsiv(iv))
-c
-c Separate total byte counts into 4 bytes
-c
- do 2 ibyte = 1 , 4
- if (ndata .gt. 0) then
- byteq(ibyte) = char(mod(ndata,256))
- ndata = ishft(ndata,-8)
- else
- byteq(ibyte) = char(0)
- end if
-2 continue
-c
-c Now write front stuff for this track
-c
- write(51,'(a,$)')'MTrk'//byteq(4)//byteq(3)//byteq(2)//byteq(1)
- * //char(0)//char(12*16+icmm(icm))//char(midinst(iinsiv(iv)))
- * //char(0)//char(11*16+icmm(icm))//char(10)//char(midbc(icm))
- if (debugmidi) write(52,'(a4,z2,a7,11z4)')'icm=',icm,
- * ' "MTrk"',ichar(byteq(4)),ichar(byteq(3)),ichar(byteq(2)),
- * ichar(byteq(1)),0,12*16+icmm(icm),midinst(iinsiv(iv)),
- * 0,11*16+icmm(icm),10,midbc(icm)
- if (lnam(iinsiv(iv)) .gt. 0) then
-c
-c Add instrument name as sequence name
-c
- write(51,'(a,$)')char(0)//char(255)//char(3)
- * //char(lnam(iinsiv(iv)))
- if (debugmidi) write(52,'(4z4)')0,255,3,lnam(iinsiv(iv))
- write(51,'(a,$)')
- * inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))
- if (debugmidi) write(52,'(a)')
- * '"'//inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))//'"'
- end if
- write(tempoq,'(i2)')icm
- write(instq,'(i3)')midinst(iinsiv(iv))
- call printl('MIDI instrument '//tempoq(1:2)//' is '//instq(1:3))
-c
-c Notes: Loop over sections.
-c
- do 9 isec = 1 , nmidsec
- if (isec .lt. nmidsec) then
- mend = msecend(icm,isec)
- else
- mend = imidi(icm)
- end if
- do 10 i = msecstrt(icm,isec) , mend
- write(51,'(a,$)')char(mmidi(icm,i))
- if (debugmidi) write(52,'(z4)')mmidi(icm,i)
-10 continue
-9 continue
-c
-c Closing 4 bytes
-c
- write(51,'(a,$)')chax(0)//char(255)//char(2*16+15)//char(0)
- if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0
- if (kv .eq. 2) then
- kv = 1
- else if (iv .eq. 1) then
- go to 5
- else
- iv = iv-1
- if (twoline(iv)) kv=2
- end if
-5 continue
- write(*,'(1x,a12,(10i6))')'Bytes used:',(imidi(icm),icm=0,numchan)
- write(15,'(1x,a12,(10i6))')
- * 'Bytes used:',(imidi(icm),icm=0,numchan)
- close(51)
- if (debugmidi) close(52)
- return
- end
- subroutine Writesetsign(nInstTrans,iInstTrans,iTransKey,flag)
- parameter(nm=24)
- integer*4 iInstTrans(nm),iTransKey(nm)
- character*79 notexq
- character*1 chax
- logical flag
-c
-c Assumes notexq is blank
-c
- do 1 i = 1 , nInstTrans
- notexq = chax(92)//'setsign'
- lnote = 8
- if (iInstTrans(i) .lt. 10) then
- notexq = notexq(1:lnote)//chax(48+iInstTrans(i))
- lnote = lnote+1
- else
- write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')
- * '{',iInstTrans(i),'}'
- lnote = lnote+4
- end if
- if (iTransKey(i) .lt. 0) then
- write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')
- * '{',iTransKey(i),'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//chax(48+iTransKey(i))
- lnote = lnote+1
- end if
- write(11,'(a)')notexq(1:lnote)//'%'
-1 continue
- flag = .false.
- return
- end
- subroutine writflot(x,notexq,lenline)
- character*(*) notexq
- if (x .lt. 0.95) then
- write(notexq(lenline+1:lenline+2),'(f2.1)')x
- lenline = lenline+2
- else if (x .lt. 9.95) then
- write(notexq(lenline+1:lenline+3),'(f3.1)')x
- lenline = lenline+3
- else
- write(notexq(lenline+1:lenline+4),'(f4.1)')x
- lenline = lenline+4
- end if
- return
- end
- subroutine wsclef(iv,ninow,nclef)
-c subroutine wsclef(iv,ninow,clefq,nclef)
-c
-c Writes \setclef for instrument containing *staff* iv
-c
- parameter (nm=24)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- logical rename
-c
-c In pmx271, had removed clefq, so with 2 or more staves in
-c an instrument, had problems. So replace in 272
-c
- common /comclefq/ clefq(nm)
- character*1 clefq,chax
- character*40 temq
- common /comc8flag/ c8flag(nm)
- logical c8flag
- if (nclef .lt. 7) then
- clefq(iv) = chax(48+nclef)
- else
- clefq(iv)='9'
- end if
- if (.not.islast) return
- iv1 = 1
- do 1 iinst = 1 , ninow
- if (iv .lt. iv1+nspern(iinst)) go to 2
- iv1 = iv1+nspern(iinst)
-1 continue
- print*
- print*,'Should not be here in wsclef!'
- call stop1()
-2 continue
-c
-c Here, iinst is the instrument number with staff of clef change
-c
- iv2 = iv1+nspern(iinst)-1
- if (iinst .lt. 10) then
- temq = chax(92)//'setclef'//chax(48+iinst)
- ltem = 9
- else
- write(temq,'(a9,i2,a1)') chax(92)//'setclef{',iinst,'}'
- ltem = 12
- end if
- if (iv1 .eq. iv2) then
-c
-c Only one staff (iv) in instrument with clef change
-c
- write(11,'(a)')temq(1:ltem)//clefq(iv)//'%'
- else
- temq = temq(1:ltem)//'{'
- ltem = ltem+1
-c
-c Loop over staves, but clefq has only changed for one of them
-c
- do 3 iiv = iv1 , iv2
- temq = temq(1:ltem)//chax(48+numclef(clefq(iiv)))
- ltem = ltem+1
-3 continue
- write(11,'(a)')temq(1:ltem)//'}%'
- end if
- if (c8flag(iv)) then
-c
-c If we change FROM octave treble clef to some other, need the following.
-c
- write(11,'(a)')char(92)//'settrebleclefsymbol'//chax(48+iinst)
- * //char(92)//'trebleclef%'
- c8flag(iv) = .false.
- end if
- return
- end
- subroutine chkpmxlyr(lineq,iccount,lyrerr)
- character*128 lineq
- character*1 charq
- lyrerr = 0
-c
-c On entry, last char was "
-c
-18 call g1etchar(lineq,iccount,charq)
- if (iccount .eq. 121) then
- lyrerr = 2
- return
-c else if (charq.eq.'"') then
- else if (charq.eq.'"' .and.
- * .not.(lineq(iccount-1:iccount-1).eq.char(92))) then
- call g1etchar(lineq,iccount,charq)
-c
-c Check for raise/lower command
-c
- if (charq .eq. '@') then
-c
-c @ positions lyrics vertically for current voice
-c [a,b] above or below of the staff
-c +/- i offset, \internotes
-c
- call g1etchar(lineq,iccount,charq)
- if (index('ab',charq).eq.0) then
- lyrerr = 3
- return
- end if
- call g1etchar(lineq,iccount,charq)
- if (index('+-',charq).eq.0) then
- lyrerr = 4
- return
- end if
- call g1etchar(lineq,iccount,charq)
- if (index('0123456789',charq).eq.0) then
- lyrerr = 5
- return
- end if
- else if (charq .ne. ' ') then
-c
-c 2nd " must be followed by ' '
-c
- lyrerr = 1
- return
- end if
- return
- end if
- go to 18
- end
- subroutine dopmxlyr(lineq,iccount)
-c
-c lineq has " at iccount. Find end of lyrics string, replace "..."
-c with \pmxlyr{...}\, but also look for ~ in lyrics and replace with '\ll ',
-c (unless preceded with '\'), check length
-c
- character*128 lineq,lineqt
- character*1 sq,chax
- sq = chax(92)
- iend = lenstr(lineq,128)
-c
-c i2nd = iccount+index(lineq(iccount+1:128),'"')
-c Find position of closing '"'; must bypass any \" which is used for umlaut
-c
- i2nd = iccount+index(lineq(iccount+1:128),'"')
-2 continue
- if (lineq(i2nd-1:i2nd-1).eq.char(92)) then
- i2nd = i2nd+index(lineq(i2nd+1:128),'"')
- go to 2
- end if
- istart = iccount
-1 itilde = istart+index(lineq(istart+1:i2nd-1),'~')
- if (itilde.gt.istart.and.itilde.lt.i2nd) then
-c
-c Replace tilde if not preceded by \
-c
- if (iend .ge. 117) then
- print*,'Sorry, lyric string is too long, stopping'
- call stop1()
- else if (lineq(itilde-1:itilde-1) .eq. sq) then
- istart = itilde
- go to 1
- end if
- lineqt = lineq(1:itilde-1)//sq//'lk '
- * //lineq(itilde+1:iend)
- iend = lenstr(lineqt,128)
- i2nd = i2nd+3
- lineq = lineqt
- go to 1
- end if
- if (iccount .eq. 1) then
- lineqt = sq//'pmxlyr{'//lineq(2:i2nd-1)//'}'//sq
- * //lineq(i2nd+1:128)
- else
- lineqt = lineq(1:iccount-1)//sq//'pmxlyr{'
- * //lineq(iccount+1:i2nd-1)//'}'//sq
- * //lineq(i2nd+1:128)
- end if
- i2nd = i2nd+8
- lineq = lineqt
- if (lineq(i2nd+1:i2nd+1) .eq. '@') then
- lineqt = lineq(1:i2nd)//'at{'//lineq(i2nd+2:i2nd+4)//'}'//sq
- * //lineq(i2nd+5:128)
- lineq = lineqt
- end if
- return
- end
- subroutine inst2chan(midc,midi,midchan,nv,iinsiv,twoline)
-c propagate per-instrument quantities to per-channel ones
- parameter (nm=24)
- integer*4 midc(0:nm),midi(nm),midchan(nm,2)
- integer*2 iinsiv(nm)
- logical twoline(nm)
- do iv = nv, 1, -1
- if (twoline(iv)) then
- midc(midchan(iv,2)) = midi(iinsiv(iv))
- end if
- midc(midchan(iv,1)) = midi(iinsiv(iv))
- end do
- end
-
-
Added: trunk/Build/source/utils/pmx/pmx-src/pmx298.for
===================================================================
--- trunk/Build/source/utils/pmx/pmx-src/pmx298.for (rev 0)
+++ trunk/Build/source/utils/pmx/pmx-src/pmx298.for 2022-03-07 21:25:07 UTC (rev 62494)
@@ -0,0 +1,26079 @@
+ program pmxab
+c
+c This program, PMX, developed by Don Simons
+c (dsimons at roadrunner.com), is a preprocessor for MusiXTeX. In concert with
+c MusiXTeX and TeX, its purpose is to allow the user to create high-quality
+c typeset musical scores by including a sequence of PMX commands in an ASCII
+c input file.
+c
+c This program is free software: you can redistribute it and/or modify
+c it under the terms of the GNU General Public License as published by
+c the Free Software Foundation, either version 3 of the License, or
+c (at your option) any later version.
+c
+c This program is distributed in the hope that it will be useful,
+c but WITHOUT ANY WARRANTY; without even the implied warranty of
+c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+c GNU General Public License for more details.
+c
+c You should have received a copy of the GNU General Public License
+c along with this program. If not, see <http://www.gnu.org/licenses/>.
+c
+c
+ character*9 date
+ character*5 version,versionc
+ common /comver/ versionc
+c
+c To compile with gfortran:
+c 1. Merge all files using copy *.for epmx[nnnn].for
+c 2. Search and replace all character*65536 with character*131072
+c 3. Comment/uncomment getarg lines
+c 4. gfortran -O pmx[nnnn].for -o pmxab.exe
+c
+c To do
+c Correct Rainer's email address in manual
+c Linesplit (\\) in h
+c Tt at start of a movement.
+c Toggle midi on or off; allow midi only.
+c Page number printed on 1st page even if 1 system.
+c Still need inserted space for chordal accidentals
+c Voicewise transposition.
+c better segno
+c coda
+c duevolte
+c Fix xtup bracket direction in 2-line staves?? (maybe leave as is)
+c Sticky ornaments with shifts.
+c Deal with Werner's vertical spacing thing associated with title.
+c Multiple ties in midi
+c Werner's missing c in MIDI due to start/stop ties on same note.
+c Beams with single 64ths
+c 128ths and/or dotted 64ths
+c Close out MIDI with integral # of beats?
+c Increase ast dimensions or redo logic.
+c Does slur direction get set for user-defined single-note stem dir'ns?
+c Transpose by sections.
+c Optimization loop over sections only
+c Command-line option to read nbarss in. Write out nbarss when optimizing.
+c (or just read from .plg?)
+c Beams over bar lines.
+c 2-digit figures
+c A real coule (slanted line between notes in a chord)
+c Dotted slurs for grace notes.
+c Undotted chord notes with dotted main note.
+c Forced line break without line number
+c Fix dot moving when 2nds in chord get flipped
+c To do: increase length on notexq in dodyn
+c 2.98
+c Fix beaming in 6/2 time by setting mapfb(5) and (6) = 0 in make1bar(...)
+c 2.97
+c Fix problem with beaming after new movement command
+c 2.96 and 2.95
+c replace and '\','/'. and '"' with chax();
+c eliminate do loops with shared last line
+c delete superfluous comments in source
+c 2.94
+c Allow moving dots on main and chord note in 2-note termolos
+c Add definitions of \hbp and \hbpp to pmx.tex
+c 2.91
+c Tweak: insert \stdstemfalse before every user-shortened or lengthened stem.
+c This cancels defaul extensions to middle line and also (with 'L') allows
+c stems that are longer than 4.66 but still don't reach middle line.
+c Allow alteration of number height in multibar rest, option n.
+c Fix bug introduced in 2.89 so that the "o" in "mo800" is now OK.
+c 2.90
+c Many tweaks to allow gaps at end or middle of a system using
+c L[n]S[x] and LC[y]. New pmx.tex.
+c 2.88
+c Comment out print*,"Changed pathname to..." since it was going
+c iteration when optimizing linebreaks with the undocumented option Ao.
+c Add nv back in as argument for getmidi, so loop transferring data
+c from midivel to midvelc can be executed. This corrects bug and
+c allows per-instrument change in midi velocities at the start
+c of any block
+c Add subroutine inst2chan to transfer midi data as noted above. Works with
+c Iv but buggy when used with IT and Ib
+c 2.87
+c Allow changes to and from octave treble clef. Instrument with it
+c must only have one staff.
+c Some fixes for beam multiplicity changes at staff jumps. Must still
+c use inline for mult. increase at downward staff jump. See sjb.pmx.
+c 2.84
+c Bug fix: dots in chordal seconds
+c Bug fix: Initialize ihornb for non-beamed, down xtup
+c Bug fix: When using "AT" with 2-note x3c rD.
+c 2.83
+c Fix problems when changing to or from octave treble clef.
+c Fix beaming (or not) and number location for xtups with
+c multiple rests. Still some problems with number height but
+c can be band-aided with number height tweak option.
+c Tweak error messages for options on "R" command.
+c Allow forced beam height and slope tweaks with 2-note tremolos
+c Allow chordal note with 2-note tremolos, adding dots as needed.
+c Fix call to ncmid in beamstrt when setting start height for beam of
+c 2-note trem, by changing arg from ivx to iv
+c 2.82
+c bugfix: beams with rests, not confused with xtups.
+c x option after slur index to allow slurs to go from one voice to another.
+c x option also for ties
+c 2.81
+c Allow string of rests to end xtup
+c in chordal half-note 2-note tremolo, make chord notes open.
+c 2.80
+c Add 2-note tremolos
+c 2.78
+c Expand bufq to 131072 bytes
+c Expand maxblks tp 9600
+c Allow up to 75 pages
+c Index postscript hairpins from 1 up instead of by voice #.
+c Add option 'o' to forced beam for open notehead (\hb); set ipl(3)
+c Add option T[n], n=1,2,3 for single stem tremolo
+c 2.77
+c Enable AV+/-x+/-y to add vskip bigh before or after \eject
+c 2.76
+c 2.75
+c Bugfix: unbeamed xtups with dots: in beamn1 and beamid allow dotted 16th, and
+c 2 or 3 flags on shortened note.
+c 2.74
+c Bugfix: allow "0" as argument of @ command on lyrics string.
+c Check for and allow "\ in centered page headings with P command.
+c Check for and allow "\ in text dynamics with D command.
+c For lyrics string starting in xtuplet, insert check for inputting musixlyr.
+c For staff-crossing beamed xtuplet chords, if 2nd segment of a joined beam
+c starts with a blank rest, put '\sk' into the TeX.
+c To enable high-to-both beamed etup staff-crossing chord, for blank
+c rest at start of forced beam, shift \sk's from before to after \ib..;
+c so \ib is at start and note in upper voice has a beam to connect to.
+c Expand range of vertical xtup number shift, now stored in mult(16-22)
+c Check for and allow \" within lyrics strings, for umlauts.
+c 2.73 (160121)
+c Dirk's "..." command, to convert "text" into \pmxlyr{text}\ and insert as
+c inline TeX. Replace all '~' inside "..." and not preceded with '\', by
+c '\lk '. Right after 2nd ", replace @[a,b][+,-]n with \at{[a,b][+,-]n}\
+c Include definitions of \ly and \at in pmx.tex (2 Feb 16). After first ",
+c add (as type 2 string) '\\input musixlyr \'
+c After inputting pathname, change any '\' to '/', for Linux compatibility.
+c 2.72 (160110)
+c Really finalize \mbrest...go back to 3 args to deal with clef changes.
+c Fine tune centered whole bar rests to deal with clef changes
+c Fix bug in wsclef when >1 staff per instrument, since \setclef
+c needs to know instrument and specify clefs on all staves for that
+c instrument. Ones that were not changed by user will not be printed,
+c and will be kept the same as before.
+c Fix bug with arpegii from one voice to another in same staff.
+c 2.71 (151226)
+c Finalize mbrest mods
+c 2.705
+c Fix error message
+c 2.704 (140614)
+c Octave treble clef
+c Make horizontal ornament shift (ornhshft) floating
+c 2.703 (140323)
+c Option v[-]n at end of any figure will alter figdrop for rest of system
+c 2.702
+c Stem slurs. Only for ps, assume no other pos'n adjustments. Option "v"
+c 2.701
+c oC = coda (\code{10})
+c Move iornq(29) (blank barline) to ipl(0) (changes in pmxb, getnote)
+c oG = new seqno
+c To do: fix grace note spacing problem (partially done)
+c 2.622
+c Redefine midtc(..) and miditran(..); clean up all transpositions/key changes
+c Kn[+/-...] \ignorenats at signature changes
+c Fix tie checks in doslur() and dopsslur() to subtract iTransAmt from nolevs
+c before checking and setting pitch levels levson() and levsoff()
+c Define midisig separately from isig. Put in common commidisig.
+c Use for explicit midi signature and for accid corrections to midi piches
+c in addmidi.
+c 2.621
+c Make keyboard rest option work in xtuplets. Created subroutine
+c chkkbdrests, modified make2bar to include calls to chkkbdrests as rqd.
+c 2.620
+c Allow user-defined rest height tweaks at start of beam.
+c 2.619
+c At movement break, change \nbinstruments in \newmovement macro; add
+c 3rd arg to \newmovement in pmx.tex; modify pmxb.for and getnote.for
+c to remove call to newnoi and change call to \newmovement
+c 2.618
+c Add option Ac[l,4] to set vert and horiz size and offsets to properly
+c center page for letter or a4 paper.
+c 2.617
+c In g1etnote, change if-check for note to use index(...) instead
+c of ichar(charq) since it was messing up gfortran optimizer
+c After pmxa, search for and remove penultimate line <blank><blank>/
+c because it was screwing up linux-compiled versions
+c Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...)
+c 2.616 (111110)
+c Allow hairpins to span multiple notes groups (gulps).
+c 2.615+ (110810)
+c Fix midi when some instruments are transposed, by subtracting
+c iTransAmt(instno(iv)) from pitch values sent to via addmidi in
+c make2bar.for (for main notes) and docrd (for chord notes)
+c 2.615 (110725)
+c Fig bug with size-setting (in topfile) when instrument has >1 staves
+c 2.615 (110724)
+c Make AS[0|-|s|t]... really set sizes
+c 2.614
+c Mod notex.for to fix Terry's bug with raised dotted rests (caused
+c by double-hboxing).
+c 2.613
+c Bugfix: In pmxa, change "do while" limit to keep from overwriting instno.
+c 2.612
+c Enhance AS to allow s or t for smallsize or tinysize
+c 2.611
+c Error trap for "D" before any notes in a block.
+c 2.610
+c Instrument-wise key changes and transposition (incomplete)
+c 2.603
+c 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors
+c following reading in an include file.
+c 101121 Added some error messages in g1etset.for setup data
+c 2.602
+c Correct slur indexing in linebreakslurs.
+c Account for comment lines in line count for error messages
+c 2.601
+c Bug fix: allow 24 slurs with graces
+c 2.60 Changes made make it really big
+c increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o
+c major reprogramming, and 16 may also be a problem (icmm)
+c nm=24 (voices) done
+c 24 slurs done
+c 24 simultaneous beams (Replace index 24 by 0, so get 0-23)
+c bufq*131072 (gfortran only)
+c getarg syntax (gfortran only)
+c 2.523+
+c Fix voice numbering for normal dynamics and text dynamics
+c 2.523
+c Version of bigpmx first posted to Hiroaki's web site.
+c 2.522
+c 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it.
+c With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices.
+c 5/13/10 Fix log2 function
+c 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length.
+c 2.521+
+c 091025 Enable dotting 2nd part of linebreak slur or tie.
+c To adjust barno height due to linebreak slur, use \bnrs instead of
+c explicitly redefining \raisebarno (pmxb)
+c 2.521
+c Bugfix
+c 2.520
+c 090519 Enable ligfonts (special figured bass characters)
+c 2.519
+c Fix another bug which kept \sk from being output so misaligned some notes.
+c 2.518
+c Fix bugs: referencing fig data, char declaration for member of
+c common/comfig/
+c 2.517
+c Allow figures in voice 1 + any one other.
+c 2.516
+c Allow figures in voice #2
+c 2.515+ to do: Change manual and activate rule against clef change in voice #2.
+c 2.515
+c 071222 Changes in getnote to allow auto forced beams to start anywhere.
+c 071206 In make2bar, shift fermataup7 to left over centered pause.
+c 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line
+c staff (it was screwing up vertical justification).
+c n34 for tweaks to midi durations of quarter note septuplets.
+c To do: In ref250.tex, the tables where 's,t,)' is explained, the line
+c [+,- i] ... Vertical adjustment of the start of second segment
+c should it be replaced by
+c [s +,- i] ... Vertical adjustment of the start of second segment
+c 2.514
+c Changes in make2bar to get horizontal spacing right when normal grace
+c follows after grace
+c Changes in dograce to get octaves right for any material entered inside
+c \gaft, which shields transpose register changes from the outside world.
+c 2.513
+c In make1bar, near end, for forced beams starting with a rest, copy hgt and
+c slope tweaks to ALL notes after first, not just the second one, so if
+c there's more than one rest at start the tweaks are still observed.
+c In beamid and beamend, add stand-alone triply-flagged notes for xtups.
+c 2.512
+c Near end of pmxb, fix error trap to allow redundant 'RD'
+c Enable multiplicity down-up '][' within xtup.
+c 2.511
+c Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by
+c adjusteskz as in bar 7 of barsant.
+c 2.510a
+c Test: remove restriction on tempo changes in MIDI macros
+c Send to CM for beta testing.
+c 2.509+
+c To do: Correct manual on AS. "-" is for smaller staves.
+c 2.510
+c Forgot to declare litq, voltxtq as character in subroutine getgrace
+c 2.509
+c Corrected small bug in arpeggio shifting (ivx <= iv in call putarp)
+c 2.508
+c Allow graces in xtups. New subroutine getgrace.
+c 2.507
+c To do: Raise/lower figures.
+c To do: Add 24, 29 to list of musicsizes in manual
+c New sub adjusteskz to account for ask's when computing lengths of
+c brackets for unbeamed xtups, slopes and horizontal posn's of number
+c Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags
+c Add look-left option for keyboard rests, "L" in rest command, set iornq(30)
+c 2.506
+c Fix bug with AK, when simultaneous rests have same duration, use defaults.
+c 2.505
+c Keyboard rests AK
+c 2.504
+c Space after normal grace: option X[n]
+c Fixed og when nv .ne. noinst, by using sepsymq instead of '&'
+c (To do) length of xtup bracket when there is added non-collision space.
+c Trap musicsize if .ne. 16,20,24,29.
+c 2.503
+c Enable arpeggio left shift with ?-x
+c To do: In manual, arpeggio over 2 staves.
+c Allow musicsize of 24 and 29. Had to define meter font size explicitly,
+c also change font size for text dynamics, but not much else so far.
+c Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn
+c was called, causing error in printing replacement number.
+c 2.502
+c Incorporate Dirk Laurie's patch to use { , } , for ties.
+c Figure height adjustment: append +[n]
+c Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?)
+c 2.501
+c Readjust horizontal offset back to .8 in LineBreakTies
+c Fix zero-subscript (iudorn) in putorn
+c 2.50
+c Increase number of text-dynamics (dimension of txtdynq) per block
+c from 12 to 41.
+c Slur option n to override altered default curvature.
+c Allow default ps slur curvature tweaks with Ap+/-c
+c 2.416
+c Increase length of textdynq from 24 to 128
+c (Todo) Add comment in manual about blank lines at end.
+c Configuration file: Define subroutine getpmxmod, check path in environment
+c variable pmxmoddir, check existence, read lines into bufq after setup.
+c Increase dimension on idynn in dodyn from 4 to 10 for max number
+c of marks in a bar
+c Increase allowable # of lines from 2000 to 4000.
+c (To do) Replace definition of \liftpausc per Olivier.
+c (To do) Fix extraneous error message if RD is placed at very end.
+c 2.415
+c Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt
+c instead of redefining \xnum. Change font used to \smallfont (as for
+c normal xtups,
+c Allow slur to start on rest.
+c 2.414
+c Correct bug in crdacc when adding accidental to boundary causes number of
+c segments to decrease
+c Special rule for 3-accidental chords: If no 2nds, place them in order
+c top, bottom, middle.
+c 2.413
+c Correct bugs in chordal accidentals, related to left-shifted noteheads
+c (a) Special problems with downstem when main note needs shifting
+c (b) Assign 0 rank to boundary segs due to left-shifted noteheads
+c 2.412
+c Change default horiz shift of start of seg 2 of linebreak slurs:
+c -.7 for slurs, -1.2 for ties,
+c Use height of start of seg 1 slur itself for end of 1 and start of 2.
+c 2.411
+c "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2.
+c "s" option in start of slur/tie as precursor to vert/horiz tweaks for end
+c of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2.
+c With "Apl", curvature adjustments on starting slur command apply to seg 1,
+c those on ending command to seg 2.
+c 2.410
+c "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine
+c \xnum, \unbkt, \ovbkt.
+c "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is
+c flag, mult(5-9) is tweak value+16
+c 2.409
+c Bugfix in docrd for MIDI: Use original pitch in case main/chord were
+c switched due to 2nds.
+c Remove "o" from error message for "A" command.
+c New syntax: optional instrument number separator ":" in movement
+c break command to precede a 2-digit instrument.
+c Conditional output formats for \setname at movement break to allow
+c instrument numbers >9.
+c Bugfix in coding to raise barno due to slur over line break (pmxb)
+c Move date/version data statement in pmxab to a better place.
+c 2.408
+c Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar).
+c Bug fix in \liftPAusep in notex.for and in pmx.tex
+c Character variables for version and date
+c For up-stem single graces slurred to down-stem, shift slur start left by
+c 0.8 so slur doesn't get too short.
+c Initialize and slide mult, same as other full-program variables in /all/.
+c 2.407
+c Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n,
+c 2.406
+c Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing
+c equalization).
+c Put dimensions of double sharps and flats in crdacc (for chords).
+c Bugfix: Use sepsymq in LineBreakTies(..) instead of '&'
+c Use only first 4 bits of mult for multiplicity+8, so rest can be used
+c for other stuff.
+c Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict.
+c 2.405: Not published but saved for safety.
+c Option Aph to write \special{header=psslurs.pro} top of each page, so
+c dviselec will work OK.
+c 2.404
+c Allow slur to end on rest, but not start on a rest. Efaults height
+c of ending is default height of start (before any automatic or user-
+c defined djustments). User may adjust height as normal from default.
+c 2.403
+c Bugfix: turn off repeated beaming patterns.at end of non-last voice.
+c 2.402
+c Automatic repeated forced beams. Start with "[:" End with next explicit
+c forced beam or end of input block.
+c Increase # of forced beams per line of music per input block from 20 to 40
+c 2.401
+c Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies.
+c Makes 1st part normal shape, and starts 2nd part a little further left.
+c Enable arpeggios in xtuplets. Had to make time itar(narp) a real.
+c 2.40
+c Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap.
+c Fix non-ps-slur input to \midslur (third signed integer). Do not reverse
+c sign for down-slurs.
+c 2.359
+c Add error exit subroutine stop1 to make exit status g77-compatible..
+c Absolute octave on xtup chord note was 2 octave too high, fixed in getnote
+c Fermata on vertically shifted rest: special trap in putorn() to set height.
+c Correct multiple grace note spacing for small staves (in dograce,
+c define wheadpt1 depending on staff size)
+c 2.358
+c Allow curvature corrections at start of postscript slur, in dopsslur()
+c Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust
+c Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h]
+c Make t[ID] act like s[ID]t, most mods in spsslur().
+c Add spsslur() to read in data for ps slurs, call from getnote.
+c In beamstrt, save args for SetupB in common comipb to save them for
+c 2nd call when xtup starts with rest
+c Add spacing for ornament ")" as if it were accidental, in make2bar().
+c Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur()
+c Horiz. shift start of ps grace slur, 2 places in dograce().
+c Horiz shift end of grace slur in endslur()
+c Make st slurs into postscript ties. Separate subroutine dopsslur(),
+c Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.)
+c Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn.
+c 2.357a
+c Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote
+c 2.357
+c Increase dimension for # of lit TeX strings from 52 to 83.
+c Allow blank rest in middle of xtuplet. Only mods in g*etnote().
+c 2.356
+c Increased some dimensions from 30 to 40 to allow up to 40 pages.
+c In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt().
+c Fix parsing of "f,h,H,HH" in sslur.
+c Fix bug with cdot, note-level for slur termination (in getnote)
+c 2.355
+c Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)],
+c n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues
+c Make midi recognize ps ties in doslur.
+c Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote
+c to get octave right.
+c 2.354
+c With postscript slurs, make t-slurs real ties by inserting replacement
+c macros \tieforisu, etc, defined in pmx.tex
+c Check for open cresc or decresc at end of input block, using list[de]cresc
+c Hairpin syntax conditional on postscript slurs. Backup to fill in start
+c level, using new backfill(...). Separate height tweaks for
+c start and finish.
+c 2.353
+c K-0+n to transpose by half step (rather than just change key)
+c Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of
+c \mbrest's
+c Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end
+c of input block before movement break, and at start of block after
+c movement break, using \newmovement rather than \setzalaligne, since
+c former already redefines \stoppiece. In second case, set rptfg2='z'.
+c Make clefq(nm) common between pmxb and getnote; change references in
+c getnote at 'M' to array elements, setting all new clefs as you go.
+c 2.352
+c Remove \parskip redefinition from pmx.tex; write it into TeX file when
+c "Ae" is invoked.
+c Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine
+c \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH',
+c translate them thru mapping to (1,4,5,6) as \midslur params, then let
+c \psforts translate them back to ps slur macors.
+c 2.351
+c Number slurs from 0 up instead of 11 down, anticipating postscript slurs.
+c Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size.
+c Increase length of basenameq to 44 characters everywhere.
+c Increase dimension of mcpitch (midi-chord-pitch) to 20.
+c Set default systems per page to 1 if nv>7
+c In pmxb, move place where isystpg is reset to 0, so that \eject gets
+c written when there is just one system per page.
+c 2.35
+c Cautionary accidentals with 'c' anywhere in note symbol.
+c NEW pmx.tex with \resetsize to set size to normal or small depending on
+c current \internote. Used with new coding in dograce() to get right
+c new size in case user has \setsize'ed some lines to \smallvalue. For
+c \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font.
+c Affects pmx.tex.
+c Continuation figure with fractional length. May now mix with other figures.
+c If another figure follow Cont-fig, separate with colon.
+c 2.342
+c Bugfix in getnote to recognize relative octave shift in grace at start of
+c input block.
+c In make2bar, initialize islhgt=0 earlier than before (possible solution
+c to Suse g77 compile problem that I could not reproduce)..
+c Bugfix in beamstrt & beamn1 for r2x6 c4D d d d
+c 2.341
+c Syntax check: Forced page break page number must be > than previous.
+c Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb.
+c 2.34
+c New pmx.tex with redefined liftpausc
+c Bug fix with dotted, non-beamed xtups.
+c 2.332
+c Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads.
+c Allow arbitrary pos. input to W in g1etnote and getnote.
+c 2.331
+c Bug-fix in dodyn(..): typo on length of arg of txtdyn
+c 2.33
+c Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata()
+c 2.321
+c Rescale accidental shifts. Still use 7 bits but now map (0,127)
+c onto (-1.,5.35)
+c Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups
+c 2.32 (Noticed after posting)
+c Prohibit "/" as figure.
+c 2.32 (Posted)
+c Tidied up accidentals in chords, do spacing.
+c Still to do:
+c check for "(" on chord notes in spacing algo
+c small accids
+c double accids
+c autoshift slurs
+c 2.310
+c Extra call to precrd ahead of spacing chk, and single-note crd/acc
+c shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time.
+c 2.309
+c Alternate algo for accid shifts in chords.
+c 2.308
+c Auto horiz. notehead shifting added to precrd.
+c 2.307
+c Auto shifting of multiple accidentals in chords.
+c "Ao" in main chord note to keep accidentals in order. Set nacc(28).
+c If there are any manual main or chord note shifts, then
+c If any manual shift is preceded by "A" then
+c 1. Auto-shifting proceeds
+c 2. "A"-shifts add to autoshifts
+c 3. non-"A" shifts are ignored!
+c Else (>0 man shifts, none has "A")
+c No auto-ordering, No autoshifts,
+c End if
+c End if
+c 2.306
+c Initialize legacy note level to middle C in case user forgets to set
+c octave.
+c Shift xtup note?
+c Shift in elemskips rather than noteheads?
+c 2.305
+c Stop pmxb from multiple endvolta's at start of new page.
+c 2.304
+c "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on
+c for multiple notes in the voice, "S:" last shortened note.
+c 2.303
+c vshrink stuff all OK? Description is in pmxb.
+c 2.302
+c Toggle vshrink with "Av". vshrink normally kicks in when \interstaff
+c hits 20. This still needs work.
+c Add " /" to last line if last char is not % or /.
+c 2.301
+c Check in beamn1 for single note before multiplicity down-up.
+c allow '.PMX' as well as '.pmx'
+c 2.299
+c Correct typo in pmxb involving PMXbarnotrue.
+c Replacement printed number for xtup: Unsigned integer after 'n' after 'x'
+c Minor upgrade parsing xtuplet options 'x...'
+c Correct dimension of nxtinbm in make2bar.
+c 2.298
+c Account for doubled xtup notes in subroutine getx (user-defined spaces),
+c by adding ndoub as an argument..
+c 2.297
+c Created and solved compiler problem. Put drawbm(NM) in its own common.
+c Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar
+c when \centerbar is used.
+c Modify \mbrest & \CenterBar in pmx.tex to use \volta at endcor etc. Have PMX
+c use right 2nd and 3rd args for \mbrest when key, meter, or clef changes.
+c 2.296
+c Correct printed numbers for forced beams with multiple xtups. For each beam
+c make list in setupb by voice of eloff (h-offset) and mtupv (printed #)
+c Increase lengths of jobname and infileq by 20 characters
+c Enable whole notes and breves as 1st or last note of xtup in beamn1 and
+c beamend, and wholes in beamid.
+c 2.295
+c Midi balance Ib[n1]:[n2]:...[nn]
+c Single-slope beam groups [...]-[...]
+c Trap "i" unless after accidental (main notes, xtups, chord notes)
+c 2.294
+c Unequal xtups with "D" to double a note in an xtup.
+c As above, "F" will (a) increase multiplicity by 1 for marked note and next
+c one and (b) add a dot to the first one.
+c Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on
+c when "." is encountered, then correcting beam start time.(end of getnote)
+c MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]...
+c 2.293
+c Check for single notes spanning bar lines.
+c Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup
+c must be set in make2bar since beamstrt is not called, fixing problem with
+c dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix
+c problem when >2 staves.
+c Add nodur to args of dodyn, so can check if stemless and avoid height tweak
+c Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak
+c 2.292a
+c Undo syntax check for Type 2 or 3 TeX string starting in column 1.
+c Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?!
+c 2.292
+c Allow comments in xtuplets
+c Enable multiple octave jumps in grace notes.
+c Allow dynamics in xtuplets.
+c Fix bug in getdyn searching for end of text string (correct length of lineq
+c to 128)
+c Fix bug in dodyn, must ignore horiz. interaction tweak for
+c user-text (idno = 0)
+c Syntax check for Type 2 or 3 TeX string starting in column 1
+c (NOTE: later undone!)
+c Syntax check for page number > npages at forced line break.
+c 2.291
+c Fix error in AS command (accid spacing for small systems), making only
+c one spec per staff, nv total.
+c Stop using MIDI channel 10
+c 2.29
+c Fix error in console output format for # of bytes used in MIDI file.
+c Fix bug in dograce so no space is added between grace and main note when
+c there is a MIDI-only accidental.
+c Fix bug so oes?+4 works. It was too ugly to explain.
+c ...Different ways of storing accidental specs on input and output.
+c No longer zap \writezbarno in special situations.
+c Fix bug in dyntxt level on rest
+c Line spacing equalization. Add macros \starteq, \endeq, \spread, etc.
+c Activate with Ae. (Maybe later could input alternate values for
+c \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1
+c in the page, and \endeq on 1st note of next-to-last line in page.
+c 2.28
+c Flip direction of forced beam "[f..."
+c Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30)
+c Fix bug in sliding ip's for txtdyn's
+c In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99)
+c 2.27
+c Comment out lines in dodyn checking number of dynamic marks found. Voice
+c order may not be monotonic if two lines on a staff.
+c Literal dynamic: D"[text]"
+c 2.26
+c Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn,
+c increasing dimension of idynn to 4 to allow 4 symbols on same note.
+c Increase voltxtq length from 10 to 20.
+c AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough
+c accounting for ast's is done by defining effective headwidth
+c whead1 in makebar2 to be 0.8*whead.
+c 2.25
+c Fix logic bug with sepsym's when # of instruments changes.
+c Slight increases in default offsets for hairpin starts after "p"
+c 2.24
+c Hairpins D< or D> as toggle.
+c Many automatic position tweaks for letter-group dynamics and hairpins.
+c 2.23
+c Continued rhythmic shortcuts: space followed by "." or ","
+c 2.22
+c In call to doslur, change tno(...) to tnote(...). This was only
+c used when checking to slurs per stem directions, and should have been
+c the note duration all along.
+c MIDI-only accidental, bit 17 in nacc, or 27 in icrdat.
+c Use "i" anywhere in note symbol.
+c 2.21
+c Increase from 20 to 30 dimensions for movement breaks and midi sections.
+c Fix out-of-order declarations per mutex comments
+c Add "Bad error" and "Kluging" messages to log file.
+c 2.197
+c add /comips/ to save tie-check midi variables
+c For spacing of clef changes at start of input block, changed integer time
+c lastnodur to prevtn, so it works with xtups. Possible incompatibility!
+c 2.196
+c Fix Ickbug with time check in ncmid()
+c Interchange \fermataup7 and \pausec to get proper alignment
+c Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX.
+c Add defn's of \hsp, \hspp to pmx.tex
+c Fix pre-slurs on xtup chord notes.
+c Fixed raised PAuse, define \liftPAuse
+c Replace \zbreve\sk with \breve.
+c Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what
+c about "o" and 1 as shorthand for 16???? Search for "Kluge"
+c Added "vo" (voice) as MIDI instrument 55
+c Allow 3-digit page numbers (search for "toppageno")
+c Fix bug caused by prior fix (cancelling accid after bar line was ignored).
+c Fix double accids in chords
+c 2.194
+c Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if
+c block.
+c Add meter to MIDI file with every pause
+c Purify FORTRAN?
+c 2.193
+c Increased # of in-line TeX strings from 36 to 52.
+c Fix entry of # of bytes in header of tempo/meter/key track to allow >255.
+c 2.191
+c Event track: Tempos, meters, keys all together. Data in comevent
+c 2.15
+c Pretty good midi capability. Still no attention to slurs on chord notes.
+c 2.11
+c 11 Dec 99 c rm1
+c 11 Dec 99 "oes?", "oe?"
+c 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes
+c 11 Dec 99 Error message for shifted, repeated ornaments.
+c 2.10 (Version 2.1)
+c Fix bug with lowdot and xtuplets
+c 2.09
+c Fix bug with multiple ornament heights over beams, when one is . or _
+c Error message from pmxa if rest on last note of xtup.
+c Enable 12 slurs.
+c Reinstate multiple rests at start of xtup.
+c 2.07
+c Combine consecutive type-1 TeX strings.
+c \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's.
+c Fixed breve chord notes in docrd
+c Check irest(28) as well as vxtup when setting nodur for chord notes, since
+c vxtup isn't set until 1st *main* note in xtup
+c Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing.
+c 2.06+
+c Make deterministic the beam slope calculation when there are an even # of
+c slopes in list and middle two are equal magnitude but opposite sign.
+c pmxa Trap for "o:" before 1st note in block
+c Partial bug fix for 64th notes in xtuplets.
+c Make ixrest a vector, since with new time scheme may not finish xtup in
+c same notes block.
+c Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb)
+c 2.06
+c Account for changes in nv when computing \interstaff. Add a counter
+c nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever
+c setting isysflb(iflb). Note nv can only change at a forced line break.
+c Note also, iflb starts at 0!
+c 2.05
+c Automatic start of new notes group with part 2 of staff-jump beam
+c In make1bar, set irest bit 29 of lowest-voice note at same time,
+c use as flag when making notes groups.
+c For now, remove dummy blank line at end...it zaps terminal repeats.
+c 2.02
+c Fixed slur-counting bug for multiple, slurred, aftergraces.
+c 2.01
+c Increase to ask(1400)
+c Increase max forced page breaks to 18
+c Define pausc for centered pause
+c 2.0a
+c Insert dummy blank line at very end to handle input files w/o terminal CR-LF
+c pmx03r
+c Option m[n] in S symbol to change musicsize (for parts)
+c Double dotted rests now work.
+c Write file name to log file
+c Check existence of input file
+c Allow 24-char jobname, may end with ".pmx"
+c Comment out time stuff
+c Replace 3-argument getarg with 2-argument + iargc
+c Fix bug with negative noinst due to nint<=int replacement
+c move lovation of iv in isdat1 to allow iv>7.
+c Set nm=12
+c pmx03q
+c replace int(x+.001) with nint(x)
+c Write TeX file name to screen and to pml.
+c Replace char(...) with chax(...) to sovle msdev bug.
+c Bug fix: macro terminations when M is on a line by itself.
+c Bug fix: don't accumulate space for XS in pmxa.
+c Streamline Macros: use pointers to bufq instead of scratch files
+c pmx03p
+c Store input file in single character array bufq.
+c lbuf(i)*2 is length of line i
+c ipbuf is position just before next line to be read.
+c pmx03
+c Optimize read/writes
+c pmx02
+c Fix line count (for errors) when there are saved macros
+c pmx01
+c In optimize mode, open/close macros (Watch out for residual zz files!)
+c Command line input
+c Option Ao to optimize, otherwise normal processing
+c
+ccccccc
+ parameter (nks=125,nm=24,mv=24576,maxblks=9600)
+ character*128 lnholdq
+ character*131072 bufq
+ integer*2 lbuf(maxblks)
+ common /comevent/ miditime,lasttime
+ logical slmon,dbltie
+ common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
+ * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
+ * slmon(0:nm),dbltie
+ integer*2 mmidi
+ logical restpend,relacc,notmain,twoline,ismidi,crdacc
+ common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
+ * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
+ * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
+ * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
+ * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
+ * debugmidi
+ logical debugmidi
+ common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
+ * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
+ integer*2 iinsiv
+ common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
+ common /commus/ musize,whead20
+ integer*4 nbars0(nks),nbars(nks),ipoe(nks),nbari(nks)
+ real*4 poe0(nks),poe(nks)
+ logical isfirst,optimize
+ logical*4 fexist
+ character*44 jobname
+ character*47 infileq
+ common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm),
+ * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
+ * idum,itsofar(nm),nib(nm,15),nn(nm),
+ * rest(nm,200),lenbr0,lenbr1,firstline,newmeter
+ logical rest,firstline,newmeter
+ common /comdiag/ n69(0:nm),n34(0:nm)
+ logical mmacrec,gottempo
+ common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
+ * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60),
+ * mmacrec,gottempo
+ common /truelinecount/ linewcom(20000)
+c
+c Added 130302 only to get nsperi from g1etnote, for use in midi setup
+c
+ common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
+ * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
+ logical lastchar,fbon,issegno,isheadr,isvolt
+ character*1 chax
+c
+c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing
+c nmidsec section starts and stops based on PLAYING macros (not recording).
+c
+ccccccccccccccccccccccccc
+c
+ data date /'12 Dec 21'/
+ data version /'2.98'/
+c
+ccccccccccccccccccccccccc
+ data maxit,ncalls /200,0/
+ data isfirst /.true./
+c itstart = mytime()
+ versionc = version
+c
+c Initialize midi parameters
+c
+ gottempo = .false.
+ ismidi = .false.
+ debugmidi = .false.
+ relacc = .false.
+ mmacrec = .false.
+ nmidsec = 1
+ mgap = 10
+ miditime = 0
+ lasttime = 0
+ nmidcrd = 0
+ nusebl = 0
+ notmain = .false.
+ do 3 ivx = 1 , nm
+ twoline(ivx) = .false.
+ midinst(ivx) = 6
+ midivel(ivx) = 127
+ midibal(ivx) = 64
+ miditran(ivx) = 0
+3 continue
+ do 12 icm = 0 , nm
+ imidi(icm) = 0
+ restpend(icm) = .false.
+ trest(icm) = 0.
+ levson(icm) = 0
+ levsoff(icm) = 0
+ slmon(icm) = .false.
+ naccbl(icm) = 0
+ n69(icm) = 0
+ n34(icm) = 0
+ msecstrt(icm,1) = 1
+12 continue
+c
+c End of midi parameter initialization
+c
+ musize = 0
+ optimize = .false.
+ numargs = iargc()
+ if (numargs .eq. 0) then
+ print*,'You could have entered a jobname on the command line,'
+ print*,' but you may enter one now:'
+ read(*,'(a)')jobname
+ numargs = 1
+ else
+c call getarg(1,jobname,idum) ! May need to replace this w/ next line
+ call getarg(1,jobname)
+ end if
+10 ljob = lenstr(jobname,44)
+ if (ljob .gt. 44) then
+ print*,'Jobname is too long. Try again.'
+ call stop1()
+ else if (ljob .eq. 0) then
+ print*,'No was jobname entered. Try again.'
+ call stop1()
+ else if (numargs .eq. 2) then
+ if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then
+ optimize = .true.
+c call getarg(2,jobname,idum) ! May need to replace this w/ next line
+ call getarg(2,jobname)
+ numargs = 1
+ go to 10
+ else
+ print*,'Illegal option on command line'
+ call stop1()
+ end if
+ end if
+c
+c Strip ".pmx" if necessary
+c
+ ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX'))
+ if (ndxpmx .gt. 0) then
+ jobname = jobname(1:ndxpmx-1)
+ ljob = ljob-4
+ end if
+c
+c Check for existence of input file
+c
+ infileq = jobname(1:ljob)//'.pmx'
+ inquire(file=infileq,EXIST=fexist)
+ if (.not.fexist) then
+ inquire(file=jobname(1:ljob)//'.PMX',EXIST=fexist)
+ if (.not.fexist) then
+ print*,'Cannot find file '//infileq
+ call stop1()
+ else
+ infileq = jobname(1:ljob)//'.PMX'
+ end if
+ end if
+c
+c Open a log file
+c
+ open(15,file=jobname(1:ljob)//'.pml')
+ call printl('This is PMX, Version '//version//', '//date)
+ ljob4 = ljob
+ call printl('Opening '//infileq)
+ open(18,file=infileq)
+c
+c Copy input file into common buffer
+c
+ ipbuf = 0
+ linewcom(1) = 1
+ do 8 ilbuf = 1 , maxblks
+ ncomments = 0
+14 read(18,'(a)',end=9)lnholdq
+ lbuf(ilbuf) = lenstr(lnholdq,128)
+ if (lbuf(ilbuf) .eq. 0) then
+c
+c Blank line. Make it a single blank with length 1
+c
+ lbuf(ilbuf) = 1
+ lnholdq = ' '
+ end if
+c
+c Now line has at least one non blank character. Check for comment
+c As of Version 260, do not copy comments into bufq
+c But need to count %'s for error messaging
+c if (lnholdq(1:1).eq.'%') go to 14
+ if (lnholdq(1:1).eq.'%') then
+ ncomments = ncomments+1
+ go to 14
+ end if
+c
+c When here, have counted all preceding comments and have a real line
+c
+ if (ilbuf .gt. 1) then
+ linewcom(ilbuf) = linewcom(ilbuf-1)+1+ncomments
+ else
+ linewcom(1) = 1+ncomments
+ end if
+ if (ipbuf+lbuf(ilbuf).gt.131072) then
+ print*,'Too many characters in file, stopping'
+ call stop1()
+ end if
+ bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) = lnholdq
+ ipbuf = ipbuf+lbuf(ilbuf)
+8 continue
+ call printl('Too many lines in input file')
+ call stop1()
+9 continue
+c
+c Insert dummy line to handle input files w/o CR-LF at end.
+c
+ nlbuf = ilbuf-1
+c nlbuf = ilbuf
+c bufq(ipbuf+1:ipbuf+3) = ' / '
+c lbuf(nlbuf) = 3
+ close(18)
+ do 6 numit = 1 , maxit
+ if (optimize) call printl('Starting an iteration')
+c
+c When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0.
+c Otherwise, nbars0 is the input
+c When islast=.false., pmxb only returns poe's, otherwise does whole job
+c
+ call pmxa(jobname,ljob4,isfirst,nsyst,nbars0,optimize)
+ if (.not.optimize) then
+ if (ismidi) then
+c
+c This was moved here from writemidi 130302 to allow midivel,bal,tran, to be
+c set up here as functions of instrument rather than iv (staff).
+c Count up staves(iv,nv) vs instruments. Store instr# for iv in iinsiv(iv)
+c
+ nstaves = 0
+ ivt = 0
+ do 16 iinst = 1 , nm
+ nstaves = nstaves+nsperi(iinst)
+ do 17 ivtt = 1 , nsperi(iinst)
+ ivt = ivt+1
+ iinsiv(ivt) = iinst
+17 continue
+ if (nstaves .eq. nv) go to 18
+16 continue
+ print*,'Screwup!'
+ call stop1()
+18 continue
+c
+c Set up channel numbers for midi.
+c
+ numchan = 0
+ do 11 iv = nv , 1 , -1
+ if (twoline(iv)) then
+ midchan(iv,2) = numchan
+ numchan = numchan+1
+ end if
+ midchan(iv,1) = numchan
+ numchan = numchan+1
+11 continue
+c
+c numchan will now be the number of channels, but max channel # is numchan-1
+c
+c Set up velocities, balances, and midi-transpositions
+c
+ do 13 iv = nv , 1 , -1
+ if (twoline(iv)) then
+c 130302 Make these functions of instrument rather than staff (iv)
+ midvelc(midchan(iv,2)) = midivel(iinsiv(iv))
+ midbc(midchan(iv,2)) = midibal(iinsiv(iv))
+ midtc(midchan(iv,2)) = miditran(iinsiv(iv))
+ end if
+ midvelc(midchan(iv,1)) = midivel(iinsiv(iv))
+ midbc(midchan(iv,1)) = midibal(iinsiv(iv))
+ midtc(midchan(iv,1)) = miditran(iinsiv(iv))
+13 continue
+ end if
+c
+c TEMPORARY!!!
+c
+ write(15,*)'nlbuf: ',nlbuf
+ ip1 = 1
+ do 10000 ilb = 1 , nlbuf
+ ip1 = ip1+lbuf(ilb)
+10000 continue
+ iplast = ip1-1
+c
+c Check to see if (1) last line is "<blank><blank>/" and (2) next to last
+c line is "/"
+c
+ if (bufq(iplast+1-lbuf(nlbuf):iplast) .eq. ' /') then
+ if(bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)).eq.chax(47))then
+ print*,'Removing last line of "<blank><blank>/"'
+ write(15,*)'Removing last line of "<blank><blank>/"'
+ nlbuf = nlbuf-1
+ end if
+ end if
+c
+ call pmxb(.true.,poe0,ncalls,optimize)
+ if (ismidi) then
+c
+c Write midi file
+c
+ open(51,file=jobname(1:ljob)//'.mid')
+ if (debugmidi) open(52,file=jobname(1:ljob)//'.dbm')
+ call printl(' ')
+ call printl('Writing '//jobname(1:ljob)//'.mid')
+ call writemidi(jobname,ljob)
+ end if
+ close(15)
+ stop
+ end if
+ write(15,*)'nlbuf: ',nlbuf
+ ip1 = 1
+ call pmxb(.false.,poe0,ncalls,optimize)
+ call poestats(nsyst,poe0,poebar0,devnorm0)
+c
+c Save initial deviation and line breaks for later comparison
+c
+ if (numit .eq. 1) then
+ devpmx = devnorm0
+ do 20 isys = 1 , nsyst
+ nbari(isys) = nbars0(isys)
+20 continue
+ end if
+ call sortpoe(nsyst,poe0,ipoe)
+ do 1 iupord = nsyst , 1 , -1
+ isysu = ipoe(iupord)
+ print*,'isysu=',isysu
+ write(15,*)'isysu=',isysu
+c
+c Skip if system isysu has poe0 < avg or isysd has poe0 > avg
+c
+ if (poe0(isysu).lt.poebar0) go to 1
+ do 5 idnord = 1 , nsyst
+ isysd = ipoe(idnord)
+ if (isysu.eq.isysd .or. nbars0(isysd).eq.1
+ * .or. poe0(isysd).gt.poebar0) go to 5
+ do 2 isyst = 1 , nsyst
+ nbars(isyst) = nbars0(isyst)
+ if (isyst .eq. isysu) then
+ nbars(isyst) = nbars(isyst)+1
+ else if (isyst .eq. isysd) then
+ nbars(isyst) = nbars(isyst)-1
+ end if
+2 continue
+ call pmxa(jobname,ljob4,isfirst,nsyst,nbars,optimize)
+ call pmxb(.false.,poe,ncalls,optimize)
+ call poestats(nsyst,poe,poebar,devnorm)
+ if (devnorm .lt. devnorm0) then
+ devnorm0 = devnorm
+ poebar0 = poebar
+ do 4 isys = 1 , nsyst
+ nbars0(isys) = nbars(isys)
+ poe0(isys) = poe(isys)
+4 continue
+ print*,'Improved with iup,idown,devnorm:',
+ * isysu,isysd,devnorm0
+ write(15,*)'Improved with iup,idown,devnorm:',
+ * isysu,isysd,devnorm0
+ write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
+ write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
+ call sortpoe(nsyst,poe0,ipoe)
+ go to 6
+ end if
+5 continue
+1 continue
+c
+c If we get here, must have gone thru all switches and found nothing better,
+c so done!
+c
+ go to 7
+6 continue
+7 continue
+ print*,'Optimum located, numit:',numit,', ncalls:',ncalls
+ write(15,*)'Optimum located, numit:',numit,', ncalls:',ncalls
+ print*,'Final error:',devnorm0,', initial error:',devpmx
+ write(15,*)'Final error:',devnorm0,', initial error:',devpmx
+ print*,'Percentage improvement:',100.*(1-devnorm0/devpmx)
+ write(15,*)'Percentage improvement:',100.*(1-devnorm0/devpmx)
+ call printl('Initial bars/system:')
+ write(*,'(5x,20i3)')(nbari(isys),isys=1,nsyst)
+ write(15,'(5x,20i3)')(nbari(isys),isys=1,nsyst)
+ call printl('Final bars/system:')
+ write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
+ write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
+ call pmxa(jobname,ljob4,.false.,nsyst,nbars0,optimize)
+ call pmxb(.true.,poe0,ncalls,optimize)
+ close(15)
+ end
+ subroutine accsym(nacc,acsymq,lacc)
+ character*3 acsymq
+ iacc = iand(nacc,7)
+ if (iacc .eq. 1) then
+ acsymq = 'fl'
+ lacc = 2
+ else if (iacc .eq. 2) then
+ acsymq = 'sh'
+ lacc = 2
+ else if (iacc .eq. 3) then
+ acsymq = 'na'
+ lacc = 2
+ else if (iacc .eq. 5) then
+ acsymq = 'dfl'
+ lacc = 3
+ else if (iacc .eq. 6) then
+ acsymq = 'dsh'
+ lacc = 3
+ else
+ print*,'bad accidental: ',iacc
+ end if
+ return
+ end
+ subroutine addask(taskn,waskn,elaskn,
+ * fixednew,scaldold,tglp1,scfac,isudsp)
+ parameter (nm=24)
+ logical isudsp
+ common /comas1/ naskb,task(40),wask(40),elask(40)
+ common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
+ common /comtol/ tol
+ scoarg = scaldold*scfac
+ if (isudsp) then
+c
+c Find which udsp we're dealing with
+c
+ do 1 iudsp = 1 , nudsp
+ if (abs(taskn+tglp1-tudsp(iudsp)) .lt. tol) go to 2
+1 continue
+ print*,'You should note BEEE here in addask!'
+ call stop1()
+2 continue
+c
+c Fixednew and scaldold must not be changed, since udsp's are already included
+c in fsyst from pmxa, and udsp don't involve scaled space..
+c
+ if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then
+c
+c Must add user-defined space to what's there already.
+c
+ wask(naskb) = wask(naskb)+udsp(iudsp)
+ else
+c
+c This place has no other space.
+c
+ naskb = naskb+1
+ task(naskb) = taskn
+ wask(naskb) = udsp(iudsp)
+ elask(naskb) = 0.
+ end if
+ else
+c 130330 start
+ oldwask = 0.
+ oldelask = 0.
+c 130330 end
+c
+c This is a normal space, no effect if smaller than existing space
+c
+ if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then
+c
+c We already put in some space at this time
+c Check if new one needs more space than old one at same time
+c
+ if (waskn .gt. wask(naskb)) then
+c
+c 130330 We were double counting the larger space when it came 2nd
+c Need to fix but don't see how yet. Assume times came in order and
+c that last naskb defined spaces that need updating
+c
+ oldwask = wask(naskb)
+ oldelask = elask(naskb)
+c End of 130330 insertions
+ naskb = naskb-1
+ else
+ return
+ end if
+ end if
+ naskb = naskb+1
+ task(naskb) = taskn
+ wask(naskb) = waskn
+ elask(naskb) = elaskn
+c 130330 start
+c fixednew = fixednew+waskn
+c scaldold = scaldold+elaskn
+ fixednew = fixednew+waskn-oldwask
+ scaldold = scoarg+elaskn-oldelask
+c 130330 end
+ end if
+ return
+ end
+ subroutine addblank(noteq,lnoten)
+ character*8 noteq
+ character*1 tchar
+ tchar = noteq(1:1)
+ noteq = ' '//tchar
+ lnoten = 2
+ return
+ end
+ subroutine addfb(nfb,iv,tnew,t1fb,t2fb,ulfbq,ifbadd)
+ parameter (nm=24)
+ integer nfb(nm)
+ common /comtol/ tol
+ real*4 t1fb(nm,20),t2fb(nm,20)
+ character*1 ulfbq(nm,20)
+ ifbadd = 1
+ nfb(iv) = nfb(iv)+1
+ do 1 ifb = nfb(iv)-1 , 1 , -1
+ if (tnew .lt. t1fb(iv,ifb)-tol) then
+ t1fb(iv,ifb+1) = t1fb(iv,ifb)
+ t2fb(iv,ifb+1) = t2fb(iv,ifb)
+ ulfbq(iv,ifb+1) = ulfbq(iv,ifb)
+ else
+ ifbadd = ifb+1
+ go to 2
+ end if
+1 continue
+2 continue
+ t1fb(iv,ifbadd) = tnew
+ ulfbq(iv,ifbadd) = 'x'
+ return
+ end
+ subroutine addmidi(icm,nolev,iacc,midisig,time,rest,endrest)
+c subroutine addmidi(icm,nolev,iacc,isig,time,rest,endrest)
+ parameter(nm=24,mv=24576)
+ integer*2 mmidi,itk(25)
+ integer*4 itiesav(5,100)
+ character*1 notenumq
+ logical endrest,eximacc,it1found
+ logical rest
+ logical restpend,relacc,notmain,twoline,ismidi,crdacc
+ common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
+ * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
+ * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
+ * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
+ * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
+ * debugmidi
+ logical debugmidi
+ common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
+ * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
+ integer*2 iinsiv
+ logical slmon,dbltie
+ common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
+ * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
+ * slmon(0:nm),dbltie
+ common /comevent/ miditime,lasttime
+ common /comdiag/ n69(0:nm),n34(0:nm)
+c common /commidisig/ midisig(nm)
+c
+c Following variables are local but must be saved. I hope they are.
+c (3/18/00) With g77 they are not, so add a common block here.
+c
+c integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12)
+ integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:15)
+ common /comips/ ipslon,lusebl,jusebl
+c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/
+ data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/
+c
+c Cancel out barline accidentals if there's a rest.
+c
+ if (rest) naccbl(icm) = 0
+c
+c Special path to insert dummy rest at end of a section
+c
+ if (endrest) go to 20
+c
+ do 7 ion = 0 , nmidcrd
+c
+c check if this is only to get pitch of a chord note
+c
+ if (notmain) go to 6
+c
+c check for rest
+c
+ if (rest) then
+c
+c Will not put in a note, but must update timing
+c
+ if (.not.restpend(icm)) then
+c
+c First rest in sequence, save the time
+c
+ restpend(icm) = .true.
+ trest(icm) = time
+ else
+ trest(icm) = trest(icm)+time
+ end if
+c
+c Note: code checkers don't like the above due to calling addmidi(trest(icm))
+c but this only happens if rest at end of section (endrest=.true.) (called
+c from getmidi(), in which case these above lines are bypassed.
+c
+ call chkimidi(icm)
+ return
+ end if
+c
+c time tics
+c
+ if (imidi(icm).gt.0 .and. ion.eq.0) then
+ idur = mgap
+ else
+ idur = 0
+ end if
+ if (restpend(icm)) then
+ restpend(icm) = .false.
+ idur = idur+nint(15*trest(icm))
+ end if
+c
+c time to start of note
+c
+ idurvar = isetvarlen(idur,nby2on)
+ if (nby2on .gt. 4) then
+ print*,'You got >4 bytes, something is bogus.'
+ call stop1()
+ end if
+ imidi(icm) = imidi(icm)+1
+ do 2 i = 1 , nby2on
+c
+c imidi points to cell before highest (leftmost) byte. Start with lowest byte
+c at far right, fill in backwards
+c
+ mmidi(icm,imidi(icm)+nby2on-i) = mod(idurvar,256)
+ if (nby2on .gt. 1) idurvar = idurvar/256
+2 continue
+ imidi(icm) = imidi(icm)+nby2on-1
+c
+c Note-on signal
+c
+ imidi(icm) = imidi(icm)+1
+ mmidi(icm,imidi(icm)) = 9*16+icmm(icm)
+c
+c Entry point for chord note pitch determination
+c
+6 continue
+c
+c Get midi pitch. On chord iteration, only do this first time (main note),
+c since pitch was already computed for nonmain chord notes.
+c
+ if (ion .eq. 0) then
+ ipsav = nolev*12./7+11
+ ipsav0 = ipsav
+ if (midisig .ne. 0) then
+c
+c Adjust for signature
+c
+ notenumq = char(48+mod(nolev,7))
+ if (midisig.ge.index('4152630',notenumq)) then
+ ipsav = ipsav+1
+ else if (-midisig.ge.index('0362514',notenumq)) then
+ ipsav = ipsav-1
+ end if
+ end if
+c
+c Deal with accidentals.
+c
+c iacc 0 1 2 3 4 5 6 7
+c effect X fl sh na X dfl dsh X
+c iashft X -1 1 0 X -2 2 X
+c
+ jacc = 0
+ eximacc = .false.
+ if (iacc .gt. 0) then
+c
+c Adjust key-sig-adjusted pitch for explicit accidental (and exit)
+c
+ jacc = iashft(iacc)
+ eximacc = .true.
+ if (.not.relacc) jacc = jacc+ipsav0-ipsav
+c
+c (Above) Shift applies to diatonic pitch but will be added to adjusted one
+c
+ else if (naccim(icm) .gt. 0) then
+c
+c Possible implicit accidental from earlier in the bar
+c Check for prior accid in this bar at this note level
+c
+ do 3 kacc = 1 , naccim(icm)
+ if (laccim(icm,kacc) .eq. nolev) then
+ jacc = jaccim(icm,kacc)
+ eximacc = .true.
+ if (.not.relacc) jacc = jacc+ipsav0-ipsav
+ go to 4
+ end if
+3 continue
+4 continue
+ end if
+c
+c Must split off the following if block from those above because chord
+c notes can cause naccim>0, forcing us to miss other chord note's
+c accross-bar-line accidental
+c
+ if (naccbl(icm).gt.0 .and. .not.eximacc) then
+c
+c Possible carryover accid from prior bar (or prior same-pitch note).
+c
+ do 21 kacc = 1 , naccbl(icm)
+ if (laccbl(icm,kacc) .eq. nolev) then
+ jacc = jaccbl(icm,kacc)
+c
+c Since we are *using* the bar-line accid, must flag it to be saved for next.
+c
+ nusebl = nusebl+1
+ jusebl(nusebl) = jacc
+ lusebl(nusebl) = nolev
+ if (.not.relacc) jacc = jacc+ipsav0-ipsav
+ go to 22
+ end if
+21 continue
+22 continue
+ end if
+ ipsav = ipsav+jacc
+ end if
+ if (notmain) then
+ mcpitch(nmidcrd) = ipsav
+c
+c Save pitch for tie checks
+c
+ if (levson(icm).eq.nolev.and..not.slmon(icm))
+ * ipslon(icm) = ipsav
+ else
+ imidi(icm) = imidi(icm)+1
+ if (ion.eq.0) then
+ mmidi(icm,imidi(icm)) = ipsav
+ if (levson(icm).eq.nolev.and..not.slmon(icm))
+ * ipslon(icm) = ipsav
+ else
+ mmidi(icm,imidi(icm)) = mcpitch(ion)
+ end if
+ end if
+ if (ion .eq. 0) then
+c
+c Only record accids for non-chords, main chord note during chord iteration
+c and chordnotes on first call but not during iteration
+c
+ if (iacc.gt.0) then
+c
+c Set marker for accidental for possible continuations later this bar
+c but first check and clear earlier ones on same note.
+c
+ do 23 kacc = 1 , naccim(icm)
+ if (laccim(icm,kacc) .eq. nolev) then
+ do 24 macc = kacc , naccim(icm)-1
+ laccim(icm,macc) = laccim(icm,macc+1)
+ jaccim(icm,macc) = jaccim(icm,macc+1)
+24 continue
+ go to 25
+ end if
+23 continue
+ go to 26
+25 continue
+ naccim(icm) = naccim(icm)-1
+26 continue
+c
+c Flag new accidental
+c
+ naccim(icm) = naccim(icm)+1
+ laccim(icm,naccim(icm)) = nolev
+ jaccim(icm,naccim(icm)) = iashft(iacc)
+ end if
+c
+c Bail if this is a chord note on the first call (from docrd)
+c
+ if (notmain) then
+ call chkimidi(icm)
+ return
+ end if
+ end if
+c
+c Vel
+c
+ imidi(icm) = imidi(icm)+1
+ mmidi(icm,imidi(icm)) = midvelc(icm)
+ call chkimidi(icm)
+7 continue
+c
+c For tie checks
+c
+ if (levson(icm).gt.0.and..not.slmon(icm)) imidso(icm) = imidi(icm)
+c
+c Entry point for special rests at section ends (endrest=T)
+c
+20 continue
+c
+c Now insert all the ends
+c
+ do 8 ioff = 0 , nmidcrd
+ if (ioff .eq. 0) then
+c
+c time to end
+c
+ idur1 = nint(15*time)
+ if (.not.endrest .or. miditime.eq.nint(15*trest(icm))) then
+ idur = idur1-mgap
+ else
+ idur = idur1
+ end if
+c
+c Deal with roundoff problems with 7-tuplets on half or quarters
+c
+ if (idur1 .eq. 69) then
+ n69(icm) = n69(icm)+1
+c if (mod(n69(icm)+6,7) .gt. 3) idur = 58
+ if (mod(n69(icm)+6,7) .gt. 3) idur = idur1-mgap-1
+ else if (idur1 .eq. 34) then
+ n34(icm) = n34(icm)+1
+ if (mod(n34(icm)+6,7) .gt. 4) idur = idur1-mgap+1
+ end if
+ idurvar = isetvarlen(idur,nby2off)
+ if (nby2off .gt. 4) then
+ print*,'You got >4 bytes, something is bogus.'
+ call stop1()
+ end if
+ imidi(icm) = imidi(icm)+1
+ call chkimidi(icm)
+ do 1 i = 1 , nby2off
+ mmidi(icm,imidi(icm)+nby2off-i) = mod(idurvar,256)
+ if (nby2off .gt. 1) idurvar = idurvar/256
+1 continue
+ imidi(icm) = imidi(icm)+nby2off-1
+ else
+c
+c Inserting end of chord note, delta time is 0
+c
+ imidi(icm) = imidi(icm)+1
+ mmidi(icm,imidi(icm)) = 0
+ end if
+c
+c Note off
+c
+ imidi(icm) = imidi(icm)+1
+ mmidi(icm,imidi(icm)) = 8*16+icmm(icm)
+c
+c Pitch
+c
+ imidi(icm) = imidi(icm)+1
+ if (ioff .eq. 0) then
+ mmidi(icm,imidi(icm)) = ipsav
+ else
+ mmidi(icm,imidi(icm)) = mcpitch(ioff)
+ end if
+c
+c Vel
+c
+ imidi(icm) = imidi(icm)+1
+ mmidi(icm,imidi(icm)) = 0
+ call chkimidi(icm)
+ if (endrest) then
+ return
+ end if
+8 continue
+ naccbl(icm) = nusebl
+ if (nusebl .gt. 0) then
+c
+c Fix tables of "bar-line" accids that are saved due to consecutive notes.
+c
+ do 30 kacc = 1 , nusebl
+ laccbl(icm,kacc) = lusebl(kacc)
+ jaccbl(icm,kacc) = jusebl(kacc)
+30 continue
+ nusebl = 0
+ end if
+c
+c Begin tie checks
+c
+ if (slmon(icm)) then
+c
+c Prior note had a slur start
+c
+ if (levson(icm).eq.levsoff(icm) .and. iacc.eq.0) then
+c
+c We have a tie! (Assumed there would be no accidental on tie-ending note)
+c Make a list of times of all events back to the one starting at imidso+1,
+c which is at or before where the tie started. Ident tie start and stop by
+c comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie)
+c Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial
+c time.
+ nsav4tie = 0
+ imidt = imidso(icm)
+10 nsav4tie = nsav4tie+1
+ itiesav(1,nsav4tie) = igetvarlen(mmidi,icm,imidt,nbytes)
+ imidt = imidt+nbytes
+ do 11 j = 1 , 3
+ itiesav(j+1,nsav4tie) = mmidi(icm,imidt+j)
+11 continue
+ imidt = imidt+3
+ if (nsav4tie .eq. 1) then
+ itiesav(5,1) = itiesav(1,1)
+ else
+ itiesav(5,nsav4tie) = itiesav(1,nsav4tie)+
+ * itiesav(5,nsav4tie-1)
+ end if
+ if (imidt .ne. imidi(icm)) go to 10
+c
+c Find which two pitches agree with saved slur pitch.
+c
+ it1found = .false.
+ do 12 it2 = 1 , nsav4tie
+ if (itiesav(3,it2) .eq. ipslon(icm)) then
+ if (it1found) go to 13
+ it1 = it2
+ it1found = .true.
+ end if
+12 continue
+ call printl(
+ * 'Program error, tied notes, send source to Dr. Don')
+ it1 = nsav4tie+1
+ it2 = nsav4tie+1
+13 continue
+c
+c List the positions we want to keep
+c
+ jsav = 0
+ do 14 isav = 1 , nsav4tie
+ if (isav.eq.it1 .or. isav.eq.it2) go to 14
+ jsav = jsav+1
+ itk(jsav) = isav
+14 continue
+ nsav4tie = nsav4tie-2
+c
+c Now dump events it1 & it2, recompute times, restack mmidi.
+c
+ imidi(icm) = imidso(icm)
+ do 15 isav = 1 ,nsav4tie
+ if (isav .eq. 1) then
+ idurvar = isetvarlen(itiesav(5,itk(isav)),nbytes)
+ else
+ idurvar = isetvarlen(itiesav(5,itk(isav))-
+ * itiesav(5,itk(isav-1)),nbytes)
+ end if
+ imidi(icm) = imidi(icm)+1
+ do 16 i = 1 , nbytes
+ mmidi(icm,imidi(icm)+nbytes-i) = mod(idurvar,256)
+ if (nbytes .gt. 1) idurvar = idurvar/256
+16 continue
+ imidi(icm) = imidi(icm)+nbytes-1
+ do 17 i = 2 , 4
+ imidi(icm) = imidi(icm)+1
+ mmidi(icm,imidi(icm)) = itiesav(i,itk(isav))
+17 continue
+15 continue
+ end if
+ slmon(icm) = .false.
+ levsoff(icm) = 0
+ if (.not.dbltie) levson(icm) = 0
+ end if
+ if (levson(icm).gt.0) slmon(icm) = .true.
+ if (nmidcrd .gt. 0) nmidcrd = 0
+ call chkimidi(icm)
+ return
+ end
+ subroutine addstr(notexq,lnote,soutq,lsout)
+ common /comlast/ islast,usevshrink
+ logical islast,usevshrink
+ character*(*) notexq
+ character*80 soutq
+ if (lsout+lnote .gt. 72) then
+ if (islast) write(11,'(a)')soutq(1:lsout)//'%'
+ lsout = 0
+ end if
+ if (lsout .gt. 0) then
+ soutq = soutq(1:lsout)//notexq(1:lnote)
+ else
+ soutq = notexq(1:lnote)
+ end if
+ lsout = lsout+lnote
+ return
+ end
+ subroutine adjusteskz(ib,istart,poenom)
+c
+c For block ib, this adds accidental spaces to eskz, for use in getting
+c length of xtup bracket and slopes of brackets and beams.
+c
+ parameter (nm=24)
+ common /comas1/ naskb,task(40),wask(40),elask(40)
+ integer*4 istart(80)
+ common /comnsp/ space(80),nb,prevtn(nm),
+ * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
+ common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
+ * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
+ * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
+ * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
+ * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
+ * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
+ * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
+ * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
+ * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
+ character*1 ulq,sepsymq,sq
+ logical beamon,firstgulp,figbass,figchk,isfig
+ common /comeskz2/ eskz2(nm,200)
+ common /comtol/ tol
+ common /comntot/ ntot
+ inmin = istart(ib)+1
+ do 10 iaskb = 1 , naskb
+ if (task(iaskb) .lt. to(istart(ib))-tol) go to 10
+ eskadd = wask(iaskb)/poenom-elask(iaskb)
+ do 11 in = inmin , ntot
+ if (to(in) .gt. task(iaskb)-tol) then
+ eskz2(ivxo(in),ipo(in)) = eskz2(ivxo(in),ipo(in))+eskadd
+ if (abs(to(in)-task(iaskb)).lt. tol) inmin=inmin-1
+ else
+ inmin = inmin+1
+ end if
+11 continue
+10 continue
+ return
+ end
+ subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0)
+ logical figbass,ispoi,topmods,istype0,done,isbbm
+ common /comhsp/ hpttot(176)
+ common /compoi/ ispoi
+ common /combbm/ isbbm
+ common /comas3/ ask(2500),iask,topmods
+ character*40 pathnameq
+ character*44 basenameq
+ character*1 sq,chax
+ character*129 outq
+ sq = chax(92)
+ open(12,file=pathnameq(1:lpath)//basenameq(1:lbase)//'.tex')
+c
+c Transfer first 5 lines of main internal TeX file
+c
+ do 11 il = 1 , 5
+ call moveln(11,12,done)
+11 continue
+ if (istype0) then
+c
+c Transfer literal TeX stuff from special scratch file
+c
+ rewind(17)
+10 call moveln(17,12,done)
+ if (.not.done) go to 10
+ close(17)
+ end if
+c
+c Transfer next 2 lines from main scratch file
+c
+ do 3 il = 1 , 2
+ call moveln(11,12,done)
+3 continue
+ if (ispoi) write(12,'(a)')sq//'input musixpoi'
+ if (isbbm) write(12,'(a)')sq//'input musixbbm'
+ if (figbass) then
+c
+c Transfer .fig data from scratch (unit 14) into external .tex (unit 12)
+c
+4 call moveln(14,12,done)
+ if (.not.done) go to 4
+ close(14)
+ end if
+ iask = 0
+ ihs = 0
+1 read(11,'(a129)',end=999)outq
+c
+c Hardspaces.
+c
+ if (outq(1:5) .eq. sq//'xard') then
+ ihs = ihs+1
+ outq(2:2) = 'h'
+ write(outq(12:15),'(f4.1)')hpttot(ihs)
+ lenout = 19
+ go to 9
+ end if
+c
+c This part hard-wires ask's into new .tex file as ast's
+c
+2 indxask = index(outq,sq//'ask')
+ if (indxask .ne. 0) then
+ iask = iask+1
+ call putast(ask(iask),indxask,outq)
+ go to 2
+ end if
+ lenout = llen(outq,129)
+9 continue
+ write(12,'(a)')outq(1:lenout)
+c
+c If this is the line with "readmod", check for topmods.
+c
+ if (topmods .and. outq(2:8).eq.'readmod') then
+ topmods = .false.
+ rewind(16)
+ do 7 il = 1 , 1000
+ read(16,'(a129)',end=8)outq
+ lenout = llen(outq,129)
+c
+c We inserted the '%' in subroutine littex, to guarantee including blank.
+c
+ write(12,'(a)')outq(1:lenout)
+7 continue
+8 continue
+ close(16)
+ end if
+ go to 1
+999 close(11)
+ close(12)
+ return
+ end
+ subroutine backfill(iunit,oldq,lenold,newq,lennew)
+c
+c In iunit, looks backward for oldq, overwrites newq
+c Safest if both are same length!
+c
+ character*128 lineq(200),nowq
+ character*(*) oldq,newq
+ linesback = 0
+1 continue
+ backspace(iunit)
+ read(iunit,'(a)')nowq
+ ndx = index(nowq,oldq(1:lenold))
+c
+c Save the line just read
+c
+ linesback = linesback+1
+ lineq(linesback) = nowq
+ if (ndx .eq. 0) then
+ backspace(iunit)
+ go to 1
+ end if
+c
+c If here, it's replacement time.
+c
+ lineq(linesback) = nowq(1:ndx-1)//newq(1:lennew)
+ * //nowq(ndx+lenold:128)
+ backspace(iunit)
+ do 2 line = linesback , 1 , -1
+ write(iunit,'(a128)')lineq(line)
+2 continue
+ return
+ end
+ subroutine beamend(notexq,lnote)
+ parameter (nm=24)
+ common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
+ * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
+ * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
+ * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
+ * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
+ * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
+ * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
+ * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
+ * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
+ character*1 ulq,sepsymq,sq,ulqq,chax
+ logical beamon,firstgulp,figbass,figchk,flipend,btest,
+ * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm
+ common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2,multbj1
+ common /comoct/ noctup
+ common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
+ * mtupv(nm,9),nxtinbm(nm),
+ * islope(nm),xelsk(24),eloff(nm,9),
+ * nssb(nm),issb(nm),lev1ssb(nm,20)
+ common /comdraw/ drawbm(nm)
+ common /commvl/ nvmx(nm),ivmx(nm,2),ivx
+ common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
+ character*4 tempq
+ character*8 noteq
+ character*79 notexq
+ ip = ipo(jn)
+ multip = iand(mult(ivx,ip),15)-8
+ lnote = 0
+ if (ixrest(ivx) .eq. 4) then
+c
+c This is the LAST note in the xtup (i.e., all rests before). Make single.
+c
+ nodur(ivx,ip) = 2**(4-multip)
+ call notex(notexq,lnote)
+ ixrest(ivx) = 0
+ return
+ end if
+ nole = nolev(ivx,ip)
+c
+c Check for special situations with 2nds (see precrd)
+c
+ if (btest(nacc(ivx,ip),30)) then
+ nole = nole - 1
+ else if (btest(nacc(ivx,ip),31)) then
+ nole = nole + 1
+ end if
+c
+c Terminate indented beams for 2-note tremolo if needed
+c
+ if (btest(irest(ivx,ip-1),2) .and.
+ * igetbits(irest(ivx,ip-1),2,5) .gt. 0) then
+ nindent = igetbits(irest(ivx,ip-1),2,5)
+ if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
+ addoff = -1-.5*nindent
+ else
+ addoff = 1+.5*nindent
+ endif
+c addoff = addoff+(.595-.065*abs(islope(ivx)))*islope(ivx)
+ addoff = addoff+.0822*islope(ivx)
+ if (addoff .lt. -.05) then
+ write(tempq,'(f4.1)')addoff
+ else
+ write(tempq,'(f4.2)')addoff
+ end if
+ notexq = sq//'raise'//tempq(1:4)//sq//'internote'//sq//'hbox{'
+ * //sq//'loffset{.7}{'//sq//'tb'//ulq(ivx,ibmcnt(ivx))//
+ * '0}}'
+ lnote = 46
+ end if
+ if (.not.drawbm(ivx)) then
+c
+c Xtuplet with no beam, just put in the right kind of note
+c
+ if (btest(irest(ivx,ip),0)) then
+c
+c Rest at end of unbeamed xtup
+c
+ lnote = 3
+ if (btest(islur(ivx,ip),29)) then
+ notexq = sq//'sk'
+c
+c 180106 There was a problem with nolev(ivx,ip) not being set to 0 for
+c a blank rest ending xtup, but hopefully returning from here will handle it.
+c
+ return
+ else if (multip .eq. 0) then
+ notexq = sq//'qp'
+ else if (multip .eq. -1) then
+ notexq = sq//'hp'
+ else if (multip .eq. 1) then
+ notexq = sq//'ds'
+ else if (multip .eq. 2) then
+ notexq = sq//'qs'
+ else
+ notexq = sq//'hs'
+ end if
+c
+c 180106 Deal with possible level tweak
+c
+ nole = mod(nolev(ivx,ip)+50,100)-50
+ if (nole .ne. 0) then
+ if (abs(nole) .lt. 10) then
+ noteq = chax(48+abs(nole))
+ lnoten = 1
+ else
+ write(noteq(1:2),'(i2)')abs(nole)
+ lnoten = 2
+ end if
+ if (nole .gt. 0) then
+ notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote'
+ * //notexq(1:lnote)
+ else
+ notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote'
+ * //notexq(1:lnote)
+ end if
+ lnote = 16+lnoten+lnote
+ end if
+ return
+ end if
+ if (btest(islur(ivx,ip),30)) then
+c
+c Forced stem direction
+c
+ ndsav = nodur(ivx,ip)
+ nodur(ivx,ip) = 2**(4-multip)
+ if (btest(nacc(ivx,ip-1),27))
+ * nodur(ivx,ip)=nodur(ivx,ip)/2
+ call notex(notexq,lnote)
+ nodur(ivx,ip) = ndsav
+ else
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip))
+ if (lnoten .eq. 1) call addblank(noteq,lnoten)
+c
+c To reduce confusion due to this early update of lnote, do it
+c below, separately in each case/
+c lnote = lnoten+3
+ if (.not.btest(nacc(ivx,ip-1),27)) then
+c
+c Prior note is not regular-dotted
+c
+ if (btest(irest(ivx,ip-1),2) .and.
+ * igetbits(irest(ivx,ip-1),2,5) .gt. 0) then
+c
+c Unbeamed tremolo with indented beams. Put termination in right here
+c
+ nindent = igetbits(irest(ivx,ip-1),2,5)
+ if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
+ addoff = -1-.5*nindent
+ else
+ addoff = 1+.5*nindent
+ endif
+c
+c Is there an islope here, for unbeamed?
+c
+ if (addoff .lt. -.05) then
+ write(tempq,'(f4.1)')addoff
+ else
+ write(tempq,'(f4.2)')addoff
+ end if
+ notexq = sq//'raise'//tempq(1:4)//sq//'internote'//sq//
+ * 'hbox{'
+ * //sq//'loffset{.7}{'//sq//'tb'//ulq(ivx,ibmcnt(ivx))//
+ * '0}}'
+ lnote = 46
+ end if
+ if (multip .eq. 0) then
+ if (btest(irest(ivx,ip-1),2) .and.
+ * nodur(ivx,ip).gt.24) then
+c
+c 2nd note of unbeamed half-note trem; make open
+c But it's not clear if unbeamed half-note tremolo is Kosher,
+c so don't worry about stem lengths here now.
+c
+ if (lnote .eq. 0) then
+ notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
+ else
+ notexq = notexq(1:46)//
+ * sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
+ lnote = 46
+ end if
+ else
+ if (btest(irest(ivx,ip-1),2) .and.
+ * nodur(ivx,ip).eq.24 .or. nodur(ivx,ip).eq.12) then
+c
+c Need a dot.
+c
+ lnote = 46
+ if (lnoten .eq. 1) then
+ noteq = ' '//noteq(1:1)
+ lnoten = 2
+ end if
+c
+c Insert stemlength stuff here for unbeamed dotted tremolo.
+c May later combine with below to avoid repeat. But need to
+c return to normal stem length after note is set.
+c
+ nindent = igetbits(irest(ivx,ip-1),2,5)
+ if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
+ slen = (4.5+nindent+nolev1(ivx)-nole
+ * +1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7)
+ * *islope(ivx)/slfac)*.6667
+ else
+ slen = (4.5+nindent-nolev1(ivx)+nole
+ * -1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7)
+ * *islope(ivx)/slfac)*.6667
+ end if
+ write(tempq,'(f4.1)')slen
+ notexq = sq//'slx{'//tempq//'}'//notexq(1:lnote)
+ lnote = lnote+10
+ end if
+c
+c Next steps are a historical kluge to distinguish dotted unbeamed 2-note trem
+c (needs \qup) from normal xtup on dotted note (eg e44dx2 f, wants no dot)
+c
+ if (btest(irest(ivx,ip-1),2)) then
+ if (lnote .eq. 0) then
+c notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
+ notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//'p'
+ * //noteq(1:lnoten)
+ else
+ notexq = notexq(1:lnote)//sq//'q'
+c * //ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
+ * //ulq(ivx,ibmcnt(ivx))//'p'//noteq(1:lnoten)
+ end if
+c lnote = lnote+3+lnoten
+ lnote = lnote+4+lnoten
+ else
+ if (lnote .eq. 0) then
+ notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
+ * //noteq(1:lnoten)
+ else
+ notexq = notexq(1:lnote)//sq//'q'
+ * //ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
+ end if
+ lnote = lnote+3+lnoten
+ end if
+ if (btest(irest(ivx,ip-1),2) .and.
+ * nodur(ivx,ip).eq.24 .or. nodur(ivx,ip).eq.12) then
+ notexq = notexq(1:lnote)//sq//'slz'
+ lnote=lnote+4
+ end if
+ end if
+ else if (btest(irest(ivx,ip-1),2)) then
+c
+c 2nd note of unbeamed quarter or 8th trem; make quarter note
+c Get stemlength change
+c
+ lnote = 46
+ nindent = igetbits(irest(ivx,ip-1),2,5)
+ if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
+ slen = (4.5+nindent+nolev1(ivx)-nole
+ * +1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7)
+ * *islope(ivx)/slfac)*.6667
+ else
+ slen = (4.5+nindent-nolev1(ivx)+nole
+ * -1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7)
+ * *islope(ivx)/slfac)*.6667
+ end if
+ write(tempq,'(f4.1)')slen
+ notexq = notexq(1:46)//sq//'slx{'//tempq//'}'
+ lnote = lnote+10
+c
+c Check for dotted unbeamed tremolo
+c
+ if (abs(nodur(ivx,ip)/12.-nodur(ivx,ip)/12).lt..001) then
+c
+c Need a dot
+c
+ if (lnoten .eq. 1) then
+ noteq = ' '//noteq(1:1)
+ lnoten = 2
+ end if
+ if (lnote .eq. 0) then
+ notexq = sq//'pt'//noteq(1:lnoten)
+ else
+ notexq = notexq(1:lnote)//sq//'pt'//noteq(1:lnoten)
+ end if
+ lnote = lnote+3+lnoten
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip))
+ if (lnoten .eq. 1) then
+ noteq = ' '//noteq(1:1)
+ lnoten = 2
+ end if
+ end if
+ notexq = notexq(1:lnote)//
+ * sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
+c * //sq//'stemcut'
+ * //sq//'slz'
+c lnote=lnote+3+lnoten+8
+ lnote=lnote+3+lnoten+4
+ else if (multip .eq. -1) then
+ notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
+ lnote = lnoten+3
+ else if (multip .eq. 1) then
+ notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
+ lnote = lnoten+3
+ else if (multip .eq. 2) then
+ notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
+ lnote = lnoten+4
+ else if (multip .eq. 3) then
+ notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten)
+ lnote = lnoten+5
+ else if (multip .eq. -2) then
+ notexq = sq//'wh'//noteq(1:lnoten)
+ lnote = lnoten+3
+ else if (multip .eq. -3) then
+ notexq = sq//'breve'//noteq(1:lnoten)
+ lnote = lnoten+6
+ else
+ print*
+ print*,'(Error in beamend, send source to Dr. Don)'
+ call stop1()
+ end if
+ else
+c
+c Prior note is regular-dotted so this one is halved
+c
+ lnote = lnoten+3
+ if (multip .eq. 0) then
+ notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq
+ else if (multip .eq. -1) then
+ notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq
+ else if (multip .eq. -2) then
+ notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
+ else if (multip .eq. 1) then
+ notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq
+ lnote = lnoten+4
+ else if (multip .eq. 2) then
+ notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq
+ lnote = lnoten+5
+ end if
+ end if
+ end if
+ return
+ end if
+c
+c End of block for unbeamed. Problem if beamed but ends w/ rest. Try just
+c skipping the call in that case.
+c
+ if (.not.btest(irest(ivx,ip),0)) then
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip))
+ end if
+c call notefq(noteq,lnoten,nole,ncmid(iv,ip))
+c lnote = 0
+c
+c New way, with flipend, which was computed in beamstrt.
+c
+ if (flipend(ivx) .and. btest(ipl(ivx,ip),30)) then
+ ulq(ivx,ibmcnt(ivx)) = chax(225-ichar(ulq(ivx,ibmcnt(ivx))))
+ flipend(ivx) = .false.
+ end if
+ if (ip .gt. ibm1(ivx,ibmcnt(ivx))) then
+c
+c This is not a one-noter from beam-jump. Check if multiplicity has increased
+c
+ if (btest(irest(ivx,ip-1),0)) then
+c
+c Prior note is a rest, check one before that
+c
+ mp = iand(mult(ivx,ip-2),15)-8
+ else
+ mp = iand(mult(ivx,ip-1),15)-8
+ end if
+ if (multip .gt. mp) then
+c
+c Assume 1-3, 2-3, or 1-2
+c
+ do 2 imp = multip , mp+1 , -1
+ call ntrbbb(imp,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
+2 continue
+ else if (btest(nacc(ivx,ip-1),27)) then
+c
+c 2nd member of dotted xtup
+c
+ call ntrbbb(multip+1,'t',
+ * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
+ end if
+ end if
+c
+c Beam termination and direction analysis
+c
+ if (btest(irest(ivx,ip),23) .and. .not.isbjmp) then
+c
+c This is the end of the first segment in a jump-beam. ivbj1=ivx will be number
+c of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the
+c voice of the 2nd part of jumped beam. (May need special treatment for
+c multi-segment jump-beams
+c
+ isbjmp = .true.
+ ivbj1 = ivx
+ multbj1 = iand(15,mult(ivx,ip)-8)
+ ivbj2 = 0
+ end if
+ if (.not.btest(irest(ivx,ip),23)) then
+c
+c This is either a normal beamend or end of a sequence of jump-beam segments,
+c (170409) or rest at end of xtup
+c so some sort of termination is required
+c
+ ulqq = ulq(ivx,ibmcnt(ivx))
+ if (.not.isbjmp .or. ivx.ne.ivbj2) then
+ if (btest(irest(ivx,ip),0)) then
+c
+c Xtup ends with rest
+c
+ if (multip .eq. 1) then
+ notexq = sq//'ds'
+ lnote = 3
+ else if (multip .eq. 2) then
+ notexq = sq//'qs'
+ lnote = 3
+ else if (multip .eq. 3) then
+ notexq = sq//'hs'
+ lnote = 3
+ end if
+c
+c 170801 Borrowed from main rest entry way down below to get level adjustment:
+c BUT nole is like 102, not 2, so subtracted 100 for nole. Why different???
+c "... Now raise if necc."
+c
+ if (btest(islur(ivx,ip),29)) then
+c
+c Blank rest
+c
+ notexq = sq//'sk'
+ lnote = 3
+ else if (nole .ne. 0) then
+c
+c Bandaid. Odd case with rests in xtups + 2 voices where came thru here with
+c nolev=-4 but expected 100+/-. Try to fix.
+c
+ if (abs(nole).lt.30) nole = 100+nole
+c
+ if (abs(nole-100) .lt. 10) then
+ noteq = chax(48+abs(nole-100))
+ lnoten = 1
+ else
+ write(noteq(1:2),'(i2)')abs(nole-100)
+ lnoten = 2
+ end if
+c ??? if (nole .gt. 0) then
+ if (nole .gt. 100) then
+ notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote'
+ * //notexq(1:lnote)
+ else
+ notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote'
+ * //notexq(1:lnote)
+ end if
+ lnote = 16+lnoten+lnote
+ end if
+ return
+ else
+c
+c Normal termination
+c
+ call ntrbbb(1,'t',ulqq,mod(ivx,24),notexq,lnote)
+ end if
+ else
+c
+c Terminate a sequence of jump-beam segments.
+c
+ ulqq = chax(225-ichar(ulqq))
+ call ntrbbb(1,'t',ulqq,mod(ivbj1,24),notexq,lnote)
+ end if
+ end if
+c
+c Check for end of 2nd seg of staff-jump xtup chord blank rest
+c
+c if (isbjmp.and.ivx.eq.ivbj2
+ if (isbjmp
+ * .and.btest(islur(ivx,ip),29)) then
+ notexq = notexq(1:lnote)//sq//'sk'
+ return
+ end if
+c
+c And now the note, checking for open-head beamed tremolo
+c
+ if (btest(irest(ivx,ip-1),2)) then
+c
+c Check for dotted tremolo
+c
+ if (abs(nodur(ivx,ip)/12.-nodur(ivx,ip)/12).lt..001) then
+c
+c Need a dot
+c
+ if (nodur(ivx,ip).eq.24 .or. nodur(ivx,ip).eq.12) then
+c
+c Solid notehead
+c
+ notexq = notexq(1:lnote)//sq//'qbp'
+ else
+c
+c Assuming open notehead and nodur = 48
+c
+ notexq = notexq(1:lnote)//sq//'hbp'
+ end if
+ lnote = lnote+4
+ else
+ if (nodur(ivx,ip).eq.32 .or. nodur(ivx,ip).eq.48) then
+ if (lnote .gt. 0) then
+ notexq = notexq(1:lnote)//sq//'hb'
+ else
+ notexq = sq//'hb'
+ end if
+ else
+ if (lnote .gt. 0) then
+ notexq = notexq(1:lnote)//sq//'qb'
+ else
+ notexq = sq//'qb'
+ end if
+ end if
+ lnote = lnote+3
+ end if
+ else
+c
+c No tremolo
+c
+ if (lnote .gt. 0) then
+ notexq = notexq(1:lnote)//sq//'qb'
+ else
+ notexq = sq//'qb'
+ end if
+ lnote = lnote+3
+ end if
+ isdotm = .false.
+ if (.not.vxtup(ivx)) then
+ if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then
+ if (.not.btest(iornq(ivx,ip),13)) then
+ notexq = notexq(1:lnote)//'p'
+ else
+ notexq = notexq(1:lnote)//'m'
+ isdotm = .true.
+ end if
+ lnote = lnote+1
+ end if
+ end if
+c
+c 5/25/08 Allow >12
+c 5/9/10 Up to 24; replace 24 with 0
+c
+ if (.not.(isbjmp.and.ivx.eq.ivbj2)) then
+ call istring(mod(ivx,24),tempq,len)
+ else
+ call istring(mod(ivbj1,24),tempq,len)
+ end if
+ if (isbjmp .and. ivx.eq.ivbj2
+ * .and..not.btest(irest(ivx,ip),23)) isbjmp=.false.
+ notexq = notexq(1:lnote)//tempq(1:len)
+ lnote = lnote+len
+ notexq = notexq(1:lnote)//noteq(1:lnoten)
+ lnote = lnote+lnoten
+ if (isdotm) then
+ if (lnoten .eq. 1) then
+ notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}'
+ lnote = lnote+3
+ else
+ notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
+ lnote = lnote+1
+ end if
+ end if
+ return
+ end
+ subroutine beamid(notexq,lnote)
+ parameter (nm=24)
+ common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
+ * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
+ * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
+ * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
+ * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
+ * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
+ * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
+ * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
+ * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
+ character*1 ulq,sepsymq,sq,ulqq,chax
+ logical beamon,firstgulp,figbass,figchk,flipend,btest,
+ * isfig,vxtup,isdotm,isbjmp,bar1syst,isdotted,isbj2,drawbm
+ character*79 notexq
+ common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2,multbj1
+ common /comoct/ noctup
+ common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
+ common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
+ * mtupv(nm,9),nxtinbm(nm),
+ * islope(nm),xelsk(24),eloff(nm,9),
+ * nssb(nm),issb(nm),lev1ssb(nm,20)
+ common /comdraw/ drawbm(nm)
+ common /commvl/ nvmx(nm),ivmx(nm,2),ivx
+ common /comask/ bar1syst,fixednew,scaldold,
+ * wheadpt,fbar,poenom
+ character*8 noteq
+ character*4 tempq
+ lnote = 0
+ ip = ipo(jn)
+ nole = nolev(ivx,ip)
+c
+c Check for special situations with 2nds (see precrd)
+c
+ if (btest(nacc(ivx,ip),30)) then
+ nole = nole - 1
+ else if (btest(nacc(ivx,ip),31)) then
+ nole = nole + 1
+ end if
+ if (.not.btest(irest(ivx,ip),0)) then
+ multip = iand(mult(ivx,ip),15)-8
+c if (btest(islur(ivx,ip-1),3)) multip = multip+1
+c
+c (Above test OK since must have ip>1). Double dotted note preceding
+c
+c Move the following, because can't ask for note until after checking for
+c embedded xtup with number, due to ordering/octave feature.
+c
+c call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
+ end if
+ if (btest(irest(ivx,ip),28)) vxtup(ivx) = .true.
+ if (vxtup(ivx)) then
+c
+c In an xtup
+c
+ if (btest(irest(ivx,ip),0)) then
+c
+c Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK
+c
+ nodur(ivx,ip) = 2**(4-(iand(mult(ivx,ip),15)-8))
+ call notex(notexq,lnote)
+c
+c Re-zero so next note does not get confused
+c
+ nodur(ivx,ip) = 0
+ return
+ end if
+ if (.not.drawbm(ivx)) then
+c
+c Xtuplet with no beam, just put in the right kind of note
+c
+ if (btest(islur(ivx,ip),30)) then
+c
+c Forced stem direction
+c
+ ndsav = nodur(ivx,ip)
+ nodur(ivx,ip) = 2**(4-multip)
+ if (btest(nacc(ivx,ip),19) .or.
+ * btest(nacc(ivx,ip),27)) then
+ nodur(ivx,ip)=3*nodur(ivx,ip)/2
+ else if (btest(nacc(ivx,ip-1),27)) then
+ nodur(ivx,ip)=nodur(ivx,ip)/2
+ end if
+ call notex(notexq,lnote)
+ nodur(ivx,ip) = ndsav
+ else
+c
+c Use ulq for stem direction
+c
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip))
+ if (lnoten .eq. 1) call addblank(noteq,lnoten)
+ lnote = 3
+ if (.not.btest(nacc(ivx,ip-1),27)) then
+c
+c Prior note of xtup is not regular-dotted
+c
+ if (multip .eq. 0) then
+ notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
+ else if (multip .eq. -1) then
+ notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
+ else if (multip .eq. 1) then
+ notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
+ else if (multip .eq. 2) then
+ notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))
+ lnote = 4
+ else if (multip .eq. 3) then
+ notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))
+ lnote = 5
+ else if (multip .eq. -2) then
+ notexq = sq//'wh'
+ end if
+ if (btest(nacc(ivx,ip),27)) then
+c
+c This xtup note is regular dotted non-beamed xtup
+c
+c notexq = notexq(1:3)//'p'
+c lnote = 4
+ notexq = notexq(1:lnote)//'p'
+ lnote = lnote+1
+ end if
+ else
+c
+c Prior note of xtup is regular-dotted so this one is halved
+c
+ if (multip .eq. 2) then
+ notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))
+ lnote = 5
+ else if (multip .eq. 1) then
+ notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))
+ lnote = 4
+ else if (multip .eq. 0) then
+ notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
+ else if (multip .eq. -1) then
+ notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
+ else if (multip .eq. -2) then
+ notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
+ end if
+ end if
+ notexq = notexq(1:lnote)//noteq
+ lnote = lnote+lnoten
+ end if
+ return
+ else if (nodur(ivx,ip).eq.0) then
+c
+c In the beamed xtup but not the last note
+c
+ if (nodur(ivx,ip-1).gt.0) then
+c
+c Embedded Xtup, mult>0, starts here. Put in number if needed
+c
+ nxtinbm(ivx) = nxtinbm(ivx)+1
+ iud = 1
+ if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') iud = -1
+c
+c Get ip#, notelevel of middle note (or gap) in xtup
+c
+ ipmid = ip+ntupv(ivx,nxtinbm(ivx))/2
+ xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud,
+ * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8)
+ if (mod(ntupv(ivx,nxtinbm(ivx)),2).eq.0) xnlmid = (xnlmid+
+ * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud,
+ * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2
+ iflop = 0
+ if (abs(xnlmid-ncmid(iv,ip)).lt.3.) iflop = -iud
+ iup = iud+2*iflop
+ if (btest(irest(ivx,ip),14)) then
+ iup = -iup
+ iflop = 0
+ if (iud*iup .lt. 0) iflop = iup
+ end if
+c
+c Place number if needed
+c
+ if (.not.btest(islur(ivx,ip),31)) then
+ mprint = igetbits(nacc(ivx,ip),5,22)
+ if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx))
+ call putxtn(mprint,iflop,multip,iud,wheadpt,poenom,
+ * nolev1(ivx),islope(ivx),slfac,
+ * xnlmid,islur(ivx,ip),lnote,notexq,ncmid(iv,ip),nlnum,
+ * eloff(ivx,nxtinbm(ivx)),iup,irest(ivx,ip),
+ * mult(ivx,ip),.false.)
+ end if
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip))
+ else
+c
+c Intermediate note of xtup
+c
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip))
+ end if
+ else
+c
+c Last note of xtup (but not last note of beam!)
+c
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip))
+ end if
+ else if (btest(irest(ivx,ip),0)) then
+ call notex(notexq,lnote)
+ return
+ else
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip))
+ end if
+c
+c Check for string of rests up to and including last note in xtup.
+c
+c Replace next 2 lines to keep from doing this block
+c when in second part of staff-jumping chordal xtup. This fix could
+c break some unaccounted non-chordal staff-jum xtup situations.
+c if (vxtup(ivx) .and. btest(irest(ivx,ip+1),0) .and.
+c * .not.btest(irest(ivx,ip),0)) then
+ if (vxtup(ivx) .and. btest(irest(ivx,ip+1),0) .and.
+ * .not.btest(irest(ivx,ip),0) .and.
+ * .not.(isbjmp.and.ivx.eq.ivbj2)) then
+c
+c This note is not a rest but next is a rest. Do rests continue to
+c end of xtup, where nodur>0
+c
+ do 3 ipnow = ip+1 , ip+24
+ if (nodur(ivx,ipnow).gt.0) go to 4 ! This is last of xtup
+ if (.not.btest(irest(ivx,ipnow+1),0)) go to 5 ! Next is not rest
+c
+c If I don't go to 5, know next note IS a rest!
+c
+3 continue
+4 continue
+ call ntrbbb(1,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
+ notexq = notexq(1:lnote)//sq//'qb'
+ lnote = lnote+3
+ call istring(ivx,tempq,len)
+ notexq = notexq(1:lnote)//tempq(1:len)
+ lnote = lnote+len
+ notexq = notexq(1:lnote)//noteq(1:lnoten)
+ lnote = lnote+lnoten
+ return
+5 continue
+c
+c Check if multiplicity changes in a way requiring action,
+c unless (160211) it's blank rest on start of 2nd seg of joined beam
+c
+ else if(.not.btest(irest(ivx,ip-1),24)
+ * .or..not.btest(islur(ivx,ip-1),29)) then
+ ipleft = ip-1
+ if (btest(irest(ivx,ipleft),0)) ipleft = ipleft-1
+ if (.not.btest(islur(ivx,ipleft),20)) then
+ multl = iand(15,mult(ivx,ipleft))-8
+ else
+ multl = 1
+ end if
+ mub = multip - multl
+ ipright = ip+1
+ if (btest(irest(ivx,ipright),0)) ipright = ipright+1
+ if (.not.btest(islur(ivx,ip),20)) then
+ multr = iand(15,mult(ivx,ipright))-8
+ else
+ multr = 1
+ end if
+ mua = multr-multip
+ if (mub.gt.0 .or. mua .lt. 0) then
+c
+c Multiplicity has increased from left or will decrease to right. Need action.
+c
+ if (isbjmp .and. ivx.eq.ivbj2) then
+ ivb = ivbj1
+ ulqq = chax(225-ichar(ulq(ivx,ibmcnt(ivx))))
+ else
+ ivb = ivx
+ ulqq = ulq(ivx,ibmcnt(ivx))
+ end if
+ if (mua .ge. 0) then
+ call ntrbbb(multip,'n',ulqq,ivb,notexq,lnote)
+c
+c Test for next note being blank rest, assuming staff-crossing
+c xtup chord
+c
+ else if (multl .ge. multr .and.
+ * .not.btest(islur(ivx,ip+1),29)) then
+ do 1 im = multip , 1+multr, -1
+ call ntrbbb(im,'t',ulqq,ivb,notexq,lnote)
+1 continue
+c else
+c Test for next note being blank rest, assuming staff-crossing
+c xtup chord
+c
+ else if (.not.btest(islur(ivx,ip+1),29)) then
+ do 2 im = 1+multr, multip
+ call ntrbbb(im,'r',ulqq,ivb,notexq,lnote)
+2 continue
+ call ntrbbb(multr,'n',ulqq,ivb,notexq,lnote)
+ end if
+ else if (ip .gt. 1) then
+c
+c Check for 2nd member of dotted xtup
+c
+ if (btest(nacc(ivx,ip-1),27)) call ntrbbb(multip+1,'t',
+ * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
+ end if
+ end if
+c
+c Now put in the note
+c
+ if (lnote .gt. 0) then
+ notexq = notexq(1:lnote)//sq//'qb'
+ else
+ notexq = sq//'qb'
+ end if
+ lnote = lnote+3
+ isdotm = .false.
+ if (isdotted(nodur,ivx,ip)) then
+c
+c rule out ')'
+c
+ if (.not.btest(iornq(ivx,ip),13)) then
+ if (.not.btest(islur(ivx,ip),3)) then
+ notexq = notexq(1:lnote)//'p'
+ else
+c
+c Double dot
+c
+ notexq = notexq(1:lnote)//'pp'
+ lnote = lnote+1
+ end if
+ else
+ notexq = notexq(1:lnote)//'m'
+ isdotm = .true.
+ end if
+ lnote = lnote+1
+ else if (btest(nacc(ivx,ip),19)
+ * .or. btest(nacc(ivx,ip),27)) then
+c
+c Special dotted notation for 2:1 xtup, or normal dot in xtup
+c
+ notexq = notexq(1:lnote)//'p'
+ lnote = lnote+1
+ end if
+c
+c 5/25/08 Allow >12
+c
+ if (.not.(isbjmp.and.ivx.eq.ivbj2)) then
+c call istring(mod(ivx,12),tempq,len)
+ call istring(mod(ivx,24),tempq,len)
+ else
+c call istring(mod(ivbj1,12),tempq,len)
+ call istring(mod(ivbj1,24),tempq,len)
+ end if
+ notexq = notexq(1:lnote)//tempq(1:len)
+ lnote = lnote+len
+ notexq = notexq(1:lnote)//noteq(1:lnoten)
+ lnote = lnote+lnoten
+ if (isdotm) then
+ if (lnoten .eq. 2) then
+ notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}'
+ lnote = lnote+3
+ else
+ notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
+ lnote = lnote+1
+ end if
+ end if
+ return
+ end
+ subroutine beamn1(notexq,lnote)
+ parameter (nm=24)
+ common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
+ * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
+ * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
+ * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
+ * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
+ * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
+ * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
+ * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
+ * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
+ character*1 ulq,sepsymq,sq
+ logical beamon,firstgulp,figbass,figchk,btest,
+ * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm
+ logical gotnote
+ common /comoct/ noctup
+ common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2,multbj1
+ common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
+ * mtupv(nm,9),nxtinbm(nm),
+ * islope(nm),xelsk(24),eloff(nm,9),
+ * nssb(nm),issb(nm),lev1ssb(nm,20)
+ common /comdraw/ drawbm(nm)
+ common /commvl/ nvmx(nm),ivmx(nm,2),ivx
+ character*8 noteq,tempq,numq
+ character*79 notexq
+ gotnote = .false.
+ lnoten = 0
+ ip1 = ipo(jn)
+ multip = iand(15,mult(ivx,ip1))-8
+ if (.not.drawbm(ivx) .and. btest(irest(ivx,ip1),0)) then
+ lnote = 0
+c
+c The rest was already written in beamstrt, so just get out of here
+c
+ return
+ end if
+ nole = nolev(ivx,ipo(jn))
+c
+c Check for special situations with 2nds (see precrd)
+c
+ if (btest(nacc(ivx,ipo(jn)),30)) then
+ nole = nole - 1
+ else if (btest(nacc(ivx,ipo(jn)),31)) then
+ nole = nole + 1
+ end if
+ if (vxtup(ivx) .and. .not.drawbm(ivx)) then
+c
+c Xtuplet with no beam, just put in the right kind of note
+c
+ if (btest(islur(ivx,ip1),30)) then
+c
+c Forced stem direction
+c
+ ndsav = nodur(ivx,ip1)
+ nodur(ivx,ip1) = 2**(4-multip)
+ if (btest(nacc(ivx,ip1),19) .or.
+ * btest(nacc(ivx,ip1),27)) nodur(ivx,ip1)=3*nodur(ivx,ip1)/2
+ call notex(notexq,lnote)
+ nodur(ivx,ip1) = ndsav
+ else
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip1))
+ gotnote = .true.
+ if (lnoten .eq. 1) call addblank(noteq,lnoten)
+ lnote = 3
+ if (multip .le. 0) then
+ if ((btest(irest(ivx,ip1),2) .and.
+ * nodur(ivx,ip1+1).ge.32)
+ * .or. multip .eq. -1) then
+c
+c 1st note of unbeamed half-note trem; make open
+c
+ notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
+ else if (multip .eq. -2) then
+ notexq = sq//'wh'
+ else
+ notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
+ end if
+c
+c Check for dot
+c
+ if (btest(irest(ivx,ip1),2) .and.
+ * abs(nodur(ivx,ip1+1)/12.-nodur(ivx,ip1+1)/12).lt..001) then
+c
+c Need a dot. already called addblank for noteq
+c
+ if (lnote .eq. 0) then
+ notexq = sq//'pt'//noteq(1:lnoten)
+ lnote = 3+lnoten
+ else
+ notexq = notexq(1:lnote)//'p'
+ lnote = lnote+1
+ end if
+ end if
+c
+c Insert the stemlength calcs here for dotted, unbeamed.
+c Later may combine with below to avoid repeat.
+c
+ if (btest(irest(ivx,ip1),2)) then
+ nindent = igetbits(irest(ivx,ip1),2,5)
+ if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
+ slen = (4.5+nindent+nolev1(ivx)-nole
+ * -.4*islope(ivx)/slfac)*.6667
+ else
+ slen = (4.5+nindent-nolev1(ivx)+nole
+ * +.4*islope(ivx)/slfac)*.6667
+ end if
+ write(tempq,'(f4.1)')slen
+ notexq = sq//'slx{'//tempq(1:4)//'}'//
+ * notexq(1:lnote)
+ lnote = lnote+10
+ end if
+ else if (btest(irest(ivx,ip1),2)) then
+c
+c 1st note of unbeamed quarter or 8th trem, make a quarter note
+c
+c Stem length calcs here. The .2 factor is empirical, but
+c slfac accounts for musicsize.
+c
+ nindent = igetbits(irest(ivx,ip1),2,5)
+ if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
+ slen = (4.5+nindent+nolev1(ivx)-nole
+ * -.4*islope(ivx)/slfac)*.6667
+ else
+ slen = (4.5+nindent-nolev1(ivx)+nole
+ * +.4*islope(ivx)/slfac)*.6667
+ end if
+ write(tempq,'(f4.1)')slen
+ notexq = sq//'slx{'//tempq(1:4)//'}'//
+ * sq//'q'//ulq(ivx,ibmcnt(ivx))
+ lnote = 13
+c
+c Check for dotted 2-note trem; prepend dot to notexq if needed
+c
+ if (nodur(ivx,ip1+1).eq.12 .or.
+ * nodur(ivx,ip1+1).eq.24) then
+ if (lnoten .eq. 1) then
+ noteq = ' '//noteq(1:1)
+ lnoten = 2
+ end if
+ notexq = sq//'pt'//noteq(1:lnoten)//notexq(1:lnote)
+ lnote = lnote+3+lnoten
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip1))
+ gotnote = .true.
+ if (lnoten .eq. 1) then
+ noteq = ' '//noteq(1:1)
+ lnoten = 2
+ end if
+ end if
+ else if (multip .eq. -1) then
+ notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
+ else if (multip .eq. 1) then
+ notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
+ else if (multip .eq. 2) then
+ notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))
+ lnote = 4
+ else if (multip .eq. 3) then
+ notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))
+ lnote = 5
+ else if (multip .eq. -2) then
+ notexq = sq//'wh'
+ else if (multip .eq. -3) then
+ notexq = sq//'breve'
+ lnote = 6
+ else
+ print*
+ print*,'(Error in beamn1, send source to Dr. Don)'
+ call stop1()
+ end if
+ if (btest(nacc(ivx,ip1),19) .or. btest(nacc(ivx,ip1),27)) then
+c notexq = notexq(1:3)//'p'
+c lnote = 4
+ notexq = notexq(1:lnote)//'p'
+ lnote = lnote+1
+ end if
+ notexq = notexq(1:lnote)//noteq
+ lnote = lnote+lnoten
+ end if
+ return
+ end if
+c
+c Check if mult. decreases from 1st note to 2nd
+c
+ if (ibm2(ivx,ibmcnt(ivx)).gt.ip1
+ * .or. btest(islur(ivx,ip1),20)) then
+c
+c More than one note or single-note before a multiplicity-down-up "]["
+c
+ if (btest(islur(ivx,ip1),20)) then
+ multr = 1
+ else if (.not.btest(irest(ivx,ip1+1),0)) then
+ multr = iand(15,mult(ivx,ip1+1))-8
+ else
+ multr = iand(15,mult(ivx,ip1+2))-8
+ end if
+ lnote = 0
+c
+c Check if staff-jumper
+c
+ if (isbjmp .and. ivbj2.gt.0) then
+ ivxp = ivbj1
+ else
+ ivxp = ivx
+ end if
+ if (multr .lt. multip) then
+ do 1 im = multip , multr+1 , -1
+c
+c Right-shifted 'termination'
+c
+ if (isbjmp .and. ivbj2.gt.0) then
+c
+c Jump beam
+c
+ call ntrbbb(im,'t',ulq(ivxp,ibmcnt(ivx)),
+ * ivxp,notexq,lnote)
+ else
+c
+c Same staff
+c
+ call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivxp,notexq,lnote)
+ end if
+1 continue
+ end if
+ end if
+c
+c Check for beamed, dotted 2-note tremolo
+c
+ if (btest(irest(ivx,ip1),2) .and.
+ * abs(nodur(ivx,ip1+1)/12.-nodur(ivx,ip1+1)/12).lt..001) then
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip))
+ gotnote = .true.
+ if (lnoten .eq. 1) then
+ noteq = ' '//noteq(1:1)
+ lnoten = 2
+ end if
+ end if
+c
+c Put in the note, but check first for open-head beamed tremolo.
+c
+ if (btest(irest(ivx,ip1),2) .and. nodur(ivx,ip1+1).ge.32) then
+c
+c 2-note open head tremolo
+c
+ if (lnote .gt. 0) then
+ notexq = notexq(1:lnote)//sq//'hb'
+ else
+ notexq = sq//'hb'
+ end if
+ else
+ if (lnote .gt. 0) then
+ notexq = notexq(1:lnote)//sq//'qb'
+ else
+ notexq = sq//'qb'
+ end if
+ end if
+ lnote = lnote+3
+ if (btest(irest(ivx,ip1),2) .and.
+ * (nodur(ivx,ip1+1).eq.24.or.nodur(ivx,ip1+1).eq.12
+ * .or.nodur(ivx,ip1+1).eq.48)) then
+c
+c 2-note trem on dotted note
+c
+ notexq = notexq(1:lnote)//'p'
+ lnote = lnote+1
+ end if
+c
+c Check for dot
+c
+ isdotm = .false.
+ if (.not.vxtup(ivx)) then
+ nd = nodur(ivx,ipo(jn))
+ if (nd.ne.0) then
+ if (2**log2(nd).ne.nd) then
+ if (.not.btest(iornq(ivx,ip1),13)) then
+ if (.not.btest(islur(ivx,ip1),3)) then
+ notexq = notexq(1:lnote)//'p'
+ else
+c
+c Double dot
+c
+ notexq = notexq(1:lnote)//'pp'
+ lnote = lnote+1
+ end if
+ else
+ notexq = notexq(1:lnote)//'m'
+ isdotm = .true.
+ end if
+ lnote = lnote+1
+ end if
+ end if
+ else if (btest(nacc(ivx,ip1),19) .or.
+ * btest(nacc(ivx,ip1),27)) then
+c
+c In an xtup with special 2:1 notation with a dot on 1st note, or normal dot
+c
+ notexq = notexq(1:lnote)//'p'
+ lnote = lnote+1
+ end if
+c
+c Do the number; 0 if 12
+c 5/25/08 allow >12
+c
+ if (.not.btest(irest(ivx,ip1),24)) then
+ call istring(mod(ivx,24),numq,len)
+ else
+c
+c 1st note of staff-jumping beam
+c
+ call istring(mod(ivbj1,24),numq,len)
+ end if
+ notexq = notexq(1:lnote)//numq(1:len)
+ lnote = lnote+len
+ if (.not.gotnote) then
+ call notefq(noteq,lnoten,nole,ncmid(iv,ip1))
+ end if
+ notexq = notexq(1:lnote)//noteq(1:lnoten)
+ lnote = lnote+lnoten
+ if (isdotm) then
+ if (lnoten .eq. 1) then
+ notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}'
+ lnote = lnote+3
+ else
+ notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
+ lnote = lnote+1
+ end if
+ end if
+ return
+ end
+ subroutine beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib)
+ parameter (nm=24)
+ common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
+ * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
+ * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
+ * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
+ * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
+ * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
+ * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
+ * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
+ * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
+ character*1 ulq,sepsymq,sq
+ character*40 restq
+ character*79 inameq
+ logical beamon,firstgulp,figbass,figchk,btest,
+ * isfig,vxtup,bar1syst,addbrack,flipend,xto,drawbm
+ common /comeskz2/ eskz2(nm,200)
+ common /comoct/ noctup
+ common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
+ common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
+ * mtupv(nm,9),nxtinbm(nm),
+ * islope(nm),xelsk(24),eloff(nm,9),
+ * nssb(nm),issb(nm),lev1ssb(nm,20)
+ common /comdraw/ drawbm(nm)
+ common /comas1/ naskb,task(40),wask(40),elask(40)
+ common /comask/ bar1syst,fixednew,scaldold,
+ * wheadpt,fbar,poenom
+ common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
+ * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig,
+ * lnam(nm),inameq(nm)
+ common /commvl/ nvmx(nm),ivmx(nm,2),ivx
+ common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
+ * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
+ * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
+c
+c The following is just to save the outputs from SetupB for the case of
+c xtups starting with a rest, where beamstrt is called twice.
+c
+ common /comipb/ nnb,sumx,sumy,ipb(24),smed
+ character*1 chax
+ character*8 noteq
+ character*79 notexq,tempq
+ integer nornb(nm),ihornb(nm,24)
+ real*4 space(80),squez(80)
+ logical novshrinktop,cstuplet,usexnumt,writebrests
+ common /comnvst/ novshrinktop,cstuplet
+ common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
+ * fullsize(nm),ivxfig2,ivvfig(2,74)
+ character*10 figq
+ common /xjbeambrests/ nbrests
+ writebrests = .true.
+ ibc = ibmcnt(ivx)
+ ipb1 = ibm1(ivx,ibc)
+ multb = iand(15,mult(ivx,ipb1))-8
+ ip = ipo(jn)
+ lnote = 0
+ nvtrem = 0 ! Vertical adjustment beams for tremolo
+c
+c Compute slopes and note offsets from start of beam. Inside SetupB, for each
+c xtup in the beam, set eloff,mtupv (in comxtup) for printed number. Also
+c gets islope(ivx), transferred in common.
+c
+ if (ixrest(ivx).eq.0 .and. .not.btest(nacc(ivx,ip),21))
+ * call SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest(ivx))
+c
+c Will always come past here after entering beamstrt for 2-note tremolo, and
+c slope will have been computed, even for unbeamed. So start the indented
+c beams here. The indented tremolo bars will be added to the notexq output
+c string, under the tacet assumption that there is no horizontal shift
+c enacted by the action just before and after the call to beamstrt.
+c
+ if (btest(irest(ivx,ipb1),2) .and.
+ * igetbits(irest(ivx,ipb1),2,5) .gt. 0) then
+ nindent = igetbits(irest(ivx,ipb1),2,5)
+ tempq = sq//'roffset{.7}{'//sq//'ib'
+ ltemp = 16
+ if (nindent .eq. 2) then
+ tempq = tempq(1:16)//'b'
+ ltemp = 17
+ else if (nindent .eq. 3) then
+ tempq = tempq(1:16)//'bb'
+ ltemp = 18
+ end if
+c
+c Use beam # 0 for indented beams
+c
+ tempq = tempq(1:ltemp)//ulq(ivx,ibc)//'0'
+ ltemp = ltemp+2
+c
+c Get adjustment to nolev1 for main beam based on nindent
+c
+ if (ulq(ivx,ibc) .eq. 'u') then
+ nvtrem = nindent-1
+ else
+ nvtrem = 1-nindent
+ end if
+c
+c Get numerical position of initiation for main beam. Will adjust height at
+c closing to account for nindent
+c
+ numinit = nolev1(ivx)-ncmid(iv,ipb1)+4
+c
+c Get forced beam height tweak, apply here for indented beams
+c
+ iadj = igetbits(ipl(ivx,ipb1),6,11)-30
+ if (iadj .ne. -30) numinit = numinit+iadj
+ if (numinit.ge.0 .and. numinit.le.9) then
+ write(noteq,'(i1)') numinit
+ lnoten = 1
+ else
+ write(noteq,'(a1,i2,a1)')'{',numinit,'}'
+ lnoten = 4
+ end if
+ tempq = tempq(1:ltemp)//noteq(1:lnoten)
+ ltemp = ltemp+lnoten
+c
+c Now do the slope.
+c 170408 Baseline is in islope(ivx). Apply slope tweak if present.
+c
+ numinit = islope(ivx)
+ iadj = igetbits(ipl(ivx,ipb1),6,17)-30
+ if (iadj .ne. -30) numinit = numinit+iadj
+ if (numinit.ge.0 .and. numinit.le.9) then
+ write(noteq,'(i1,a1)') numinit,'}'
+ lnoten = 2
+ else
+ write(noteq,'(a1,i2,a2)')'{',numinit,'}}'
+ lnoten = 5
+ end if
+ tempq = tempq(1:ltemp)//noteq(1:lnoten)
+ ltemp = ltemp+lnoten
+ notexq = tempq
+ lnote = ltemp
+ end if
+ if (btest(nacc(ivx,ip),21)) then
+c
+c This is start of later segment of single-slope beam group so use slope and
+c height from prior beam. Slope is already OK.
+c
+ issb(ivx) = issb(ivx)+1
+ nolev1(ivx) = lev1ssb(ivx,issb(ivx))
+ end if
+c
+c Move this up to before indented beams for tremolo
+c lnote = 0
+ drawbm(ivx) = .true.
+ if (btest(irest(ivx,ipb1),28) .and. ixrest(ivx).ne.2) then
+ vxtup(ivx) = .true.
+ nxtinbm(ivx) = nxtinbm(ivx)+1
+c
+c irest(28)=>Xtup starts on this note. Set up for xtuplet.
+c Number goes on notehead side at middle note (or gap) of xtup, unless that
+c puts it in staff, then it flops to stem (or beam) side.
+c __ __
+c | | | O | |
+c O | | O
+c |___| O |__| |
+c
+c iud -1 -1 1 1 ...stem direction
+c iflop 0 1 -1 0 ...direction of flop
+c iup -1 1 -1 1 ...direction of number and bracket
+c
+ iud = 1
+ if (ulq(ivx,ibc) .eq. 'u') iud = -1
+c
+c Get ip#, note level of middle note (or gap) in xtup
+c
+ ipmid = ipb1+ntupv(ivx,nxtinbm(ivx))/2
+c
+c 130129 If middle note is a rest, go to next note. Note last note cannot
+c be a rest
+c
+14 continue
+ if (btest(irest(ivx,ipmid),0)) then
+ ipmid = ipmid+1
+ go to 14
+ end if
+ xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud,
+ * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8)
+ if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) xnlmid = (xnlmid+
+ * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud,
+ * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2
+ iflop = 0
+ if (abs(xnlmid-ncmid(iv,ipb1)).lt.3.) iflop = -iud
+ iup = iud+2*iflop
+ if (btest(irest(ivx,ipb1),14)) then
+c
+c Alter iud, iflop, iup to flip number/bracket. (Stare at above pic)
+c
+ iup = -iup
+ iflop = 0
+ if (iud*iup .lt. 0) iflop = iup
+ end if
+c
+c Determine if a beam is to be drawn.
+c Had problem w/ half-note 2-note xtups always F, so add a test
+c
+ if (igetbits(irest(ivx,ipb1),2,3) .ne. 0) then
+ drawbm(ivx) = .true.
+ go to 6
+ end if
+ do 5 ipp = ibm1(ivx,ibc),ibm2(ivx,ibc)
+ if (iand(15,mult(ivx,ipp))-8 .le. 0) then
+ drawbm(ivx) = .false.
+ go to 6
+ end if
+5 continue
+ drawbm(ivx) = .not.btest(islur(ivx,ibm1(ivx,ibc)),18)
+6 continue
+c
+c Are we using tuplet.tex?
+c
+ usexnumt = cstuplet .and. .not.drawbm(ivx)
+c
+c Check for single note xtup 171217
+c
+ if (btest(irest(ivx,ipb1),28) .and. nnb.eq.1) then
+ drawbm(ivx) = .false.
+ end if
+c
+c Place xtup number if needed
+c
+ if (.not.btest(islur(ivx,ipb1),31) .or. multb.le.0) then
+ mprint = igetbits(nacc(ivx,ip),5,22)
+ if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx))
+c Stab in the dark! Note: tried setting unbeam flag islur18 but no go.
+ if (nnb .eq. 1) then
+ xnlmid = nolev1(ivx)
+ islope(ivx) = 0
+c
+c Move up, outside number check block, so all 1-note xtups ar unbeamed
+c drawbm(ivx) = .false.
+c
+ end if
+ call putxtn(mprint,iflop,multb,iud,wheadpt,
+ * poenom,nolev1(ivx),islope(ivx),slfac,xnlmid,islur(ivx,ipb1),
+ * lnote,notexq,ncmid(iv,ipb1),nlnum,eloff(ivx,nxtinbm(ivx)),
+ * iup,irest(ivx,ipb1),mult(ivx,ipb1),usexnumt)
+ end if
+ if (.not.drawbm(ivx)) then
+c
+c Xtuplet with no beam
+c
+ if (.not.btest(islur(ivx,ipb1),31)) then
+c
+c Number printing has not been suppressed, so put in the bracket.
+c scale = stretch factor for bracket if there are asx's
+c xnsk = length of the bracket in \noteskips = (\elemskips)/(eon)
+c
+ xnsk = (eskz2(ivx,ipb1+ntupv(ivx,nxtinbm(ivx))-1)
+ * -eskz2(ivx,ipb1))/squez(ib)/feon(space(ib)/squez(ib))
+ if (iup .eq. 1) then
+ if (lnote .gt. 0) then
+ notexq = notexq(1:lnote)//sq//'ovbkt'
+ else
+ notexq = sq//'ovbkt'
+ end if
+ else
+ if (lnote .gt. 0) then
+ notexq = notexq(1:lnote)//sq//'unbkt'
+ else
+c
+c Introduced 12/5/98, req'd due to possible presence of in-line TeX
+c
+ notexq = sq//'unbkt'
+ end if
+ end if
+ lnote = lnote+6
+ if (iline.eq.1) then
+ smed = smed/(1.-fracindent)
+ end if
+ xslope = 1.8*smed*slfac
+ islope(ivx) = nint(xslope)
+ nolev1(ivx) = nlnum - nint(smed*eloff(ivx,1))
+ if (islope(ivx) .eq. 0) nolev1(ivx) = nolev1(ivx)-1
+ if (iup .eq. 1) nolev1(ivx) = nolev1(ivx)+4
+ levbracket = nolev1(ivx)
+ if (iup.eq.1 .and. cstuplet) levbracket = levbracket-1
+ call notefq(noteq,lnoten,levbracket,ncmid(iv,ipb1))
+ if (lnoten .eq. 1) call addblank(noteq,lnoten)
+ notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
+ lnote = lnote+lnoten+1
+ if (xnsk .lt. 0.995) then
+ write(notexq(lnote+1:lnote+4),'(i1,f3.2)')0,xnsk
+ lnote = lnote+4
+ else if (xnsk .lt. 9.995) then
+ write(notexq(lnote+1:lnote+4),'(f4.2)')xnsk
+ lnote = lnote+4
+ else
+ write(notexq(lnote+1:lnote+5),'(f5.2)')xnsk
+ lnote = lnote+5
+ end if
+ notexq = notexq(1:lnote)//'}'
+ lnote = lnote+1
+ if (btest(mult(ivx,ipb1),4)) then
+c
+c Tweak slope of bracket
+c
+ islope(ivx) = islope(ivx)+igetbits(mult(ivx,ipb1),5,5)-16
+ end if
+ if (islope(ivx).lt.0 .or. islope(ivx).ge.10) then
+ notexq = notexq(1:lnote)//'{'
+ lnote = lnote+1
+ if (islope(ivx) .lt. -9) then
+ write(notexq(lnote+1:lnote+3),'(i3)')islope(ivx)
+ lnote = lnote+3
+ else
+ write(notexq(lnote+1:lnote+2),'(i2)')islope(ivx)
+ lnote = lnote+2
+ end if
+ notexq = notexq(1:lnote)//'}'
+ lnote = lnote+1
+ else
+ write(notexq(lnote+1:lnote+1),'(i1)')islope(ivx)
+ lnote = lnote+1
+ end if
+c
+c Done with bracket
+c
+ end if
+ if (ixrest(ivx) .eq. 1) then
+c
+c Put in the rest. Possible problem: Rest is a spacing char, but between
+c beamstrt and beamn1 some non-spacing chars. are inserted.
+c
+c 130126 Deal with vertical shifts of rest starting xtuplet
+c
+ lrest = 3
+ if (btest(islur(ivx,ip),29)) then
+ restq = sq//'sk'
+c if (multb .eq. 0) then
+ else if (multb .eq. 0) then
+ restq = sq//'qp'
+ else if (.not.drawbm(ivx).and.multb.eq.1) then
+ restq = sq//'ds'
+ else if (.not.drawbm(ivx).and.multb.eq.2) then
+ restq = sq//'qs'
+ else if (.not.drawbm(ivx).and.multb.eq.3) then
+ restq = sq//'hs'
+ else
+ restq = sq//'hpause'
+ lrest = 7
+ end if
+ if (btest(nacc(ivx,ipb1),18) .and.
+ * btest(nacc(ivx,ipb1),19)) then
+c
+c VERY special case of rest at start of F-tuplet, needs dot
+c
+ restq = sq//'pt4'//restq(1:lrest)
+ lrest = lrest+4
+ end if
+
+ nole = mod(nolev(ivx,ip)+20,100)-20
+c if (nole .eq. 0) then
+ if (nole.eq.0 .or. btest(islur(ivx,ip),29)) then
+c
+c Rest blank or is not raised
+c
+ notexq = notexq(1:lnote)//restq
+ lnote = lnote+lrest
+ else
+ if (abs(nole) .lt. 10) then
+ tempq = chax(48+abs(nole))
+ ltemp = 1
+ else
+ write(tempq(1:2),'(i2)')abs(nole)
+ ltemp = 2
+ end if
+ if (nole .gt. 0) then
+ tempq = sq//'raise'//tempq(1:ltemp)//sq//'internote'
+ else
+ tempq = sq//'lower'//tempq(1:ltemp)//sq//'internote'
+ end if
+ ltemp = 16+ltemp
+ notexq = notexq(1:lnote)//tempq(1:ltemp)//restq(1:lrest)
+ lnote = lnote+ltemp+lrest
+ end if
+c
+c No need to come back through this subroutine (as would if rest starts bar
+c & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing.
+c
+ ixrest(ivx) = 0
+ end if
+ return
+ end if
+c
+c End if block for non-beamed xtup start...note we returned
+c
+ if (ixrest(ivx) .eq. 1) then
+c
+c Insert rest at start of beamed xtup. See above note for possible problem.
+c But first check if blank rest and if in forced beam (assuming xtuplet),
+c and if so, count rest from beginning, add \sk's AFTER starting beam '\ib*'
+c
+ if (btest(islur(ivx,ip),29) .and. btest(ipl(ivx,ip),30)) then
+ nbrests = nbrests+1
+ writebrests = .false.
+ else
+ nodur(ivx,ipb1) = 2**(4-multb)
+ call notex(tempq,ltemp)
+ if (lnote .gt. 0) then
+ notexq = notexq(1:lnote)//tempq(1:ltemp)
+ else
+ notexq = tempq(1:ltemp)
+ end if
+ lnote = lnote+ltemp
+ end if
+c
+c Re-zero just in case!
+c
+ nodur(ivx,ipb1) = 0
+ ibm1(ivx,ibc) = ibm1(ivx,ibc)+1
+c
+c See if next note is a non-rest
+c
+ if (.not.btest(irest(ivx,ipb1+1),0)) then
+ ixrest(ivx) = 2
+ else
+c
+c Suppress reprinting xtup number next time through beamstrt
+c
+ islur(ivx,ipb1+1) = ibset(islur(ivx,ipb1+1),31)
+c
+c Set new xtup start flag
+c
+ irest(ivx,ipb1+1) = ibset(irest(ivx,ipb1+1),28)
+ end if
+ return
+ end if
+ end if
+c
+c Just ended if block for xtups
+c
+ if (vxtup(ivx) .and. ipb1.eq.ibm2(ivx,ibc)) then
+c
+c Move actual note writing to beamend
+c
+ ixrest(ivx) = 4
+ return
+ end if
+ if (issb(ivx) .eq. 0) then
+c
+c 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed
+c
+ iadj = igetbits(ipl(ivx,ipb1),6,11)-30
+ if (iadj .ne. -30) then
+ nolev1(ivx) = nolev1(ivx)+iadj
+ do 2 isssb = 1 , nssb(ivx)
+ lev1ssb(ivx,isssb) = lev1ssb(ivx,isssb)+iadj
+2 continue
+ end if
+ iadj = igetbits(ipl(ivx,ipb1),6,17)-30
+ if (iadj .ne. -30) then
+ islope(ivx) = islope(ivx)+iadj
+ if (abs(islope(ivx)) .gt. 9) islope(ivx) = sign(9,islope(ivx))
+ if (nssb(ivx) .gt. 0) then
+c
+c Cycle thru non-rest notes in SSBG, looking for bmstrts.
+c
+ isssb = 0
+ do 4 inb = 2, nnb
+ if (btest(nacc(ivx,ipb(inb)),21)) then
+c
+c Beam segment start. New start level
+ isssb = isssb+1
+ lev1ssb(ivx,isssb) =
+ * lev1ssb(ivx,isssb)+islope(ivx)*xelsk(inb)/slfac
+ end if
+4 continue
+ end if
+ end if
+ end if
+ iadj = igetbits(islur(ivx,ipb1),2,27)
+ addbrack = .false.
+ if (btest(ipl(ivx,ipb1),30)) then
+c
+c Check for altered starting polarity. Only in forced beams. Nominal start
+c level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.).
+c
+ if (ulq(ivx,ibc).eq.'u' .and.
+ * nolev1(ivx)+6.lt.nolev(ivx,ipb1)) then
+ if (lnote .eq. 0) then
+ notexq = sq//'loff{'
+ else
+ notexq = notexq(1:lnote)//sq//'loff{'
+ end if
+ lnote = lnote+6
+ addbrack = .true.
+ else if (ulq(ivx,ibc).eq.'l' .and.
+ * nolev1(ivx)-6.gt.nolev(ivx,ipb1)) then
+ if (lnote .eq. 0) then
+ notexq = sq//'roff{'
+ else
+ notexq = notexq(1:lnote)//sq//'roff{'
+ end if
+ lnote = lnote+6
+ addbrack = .true.
+ end if
+c
+c Check end level for possible flipping in forced beam. Have to do it
+c here since with multiple voices, xelsk will not be preserved.
+c
+ if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
+ bmlev = nolev1(ivx)+6+islope(ivx)*xelsk(nnb)/slfac
+ flipend(ivx) = bmlev.lt.nolev(ivx,ibm2(ivx,ibc))
+ else if (ulq(ivx,ibmcnt(ivx)) .eq. 'l') then
+ bmlev = nolev1(ivx)-6+islope(ivx)*xelsk(nnb)/slfac
+ flipend(ivx) = bmlev.gt.nolev(ivx,ibm2(ivx,ibc))
+ end if
+ end if
+ multbb = multb+iadj
+c
+c Tremolo starting?
+c
+ if (btest(irest(ivx,ipb1),2)) multbb =
+ * igetbits(irest(ivx,ipb1),2,3)
+ call ntrbbb(multbb,'i',ulq(ivx,ibc),ivx,notexq,lnote)
+c
+c Put in name of start level and slope, after correcting nolev1 if xtup
+c started with a rest.
+c
+ if (ixrest(ivx).eq.2) nolev1(ivx) =
+ * nint(nolev1(ivx)+xelsk(1)*islope(ivx)/slfac)
+c
+c Add adjustment nvtrem to main beam to account for tremolo indented beams
+c
+ call notefq(noteq,lnoten,nolev1(ivx)+nvtrem,ncmid(iv,ipb1))
+ if (islope(ivx) .lt. 0) then
+ notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
+ lnote = lnote+4+lnoten
+ write(notexq(lnote-2:lnote),'(i2,a1)')islope(ivx),'}'
+ else
+ notexq = notexq(1:lnote)//noteq(1:lnoten)
+ lnote = lnote+1+lnoten
+ write(notexq(lnote:lnote),'(i1)')islope(ivx)
+ end if
+c
+c Check for beam-thk fine-tuning
+c
+ if (iadj .gt. 0) then
+ do 1 imp = multb+iadj , multb+1 , -1
+ call ntrbbb(imp,'t',ulq(ivx,ibc),ivx,notexq,lnote)
+1 continue
+ end if
+c
+c If we shifted, must close with right bracket
+c
+ if (addbrack) then
+ notexq = notexq(1:lnote)//'}'
+ lnote = lnote+1
+ end if
+c
+c Add in \sk's for very special case of staff-crossing xtup chords
+c Assumes we are in lower (first) voice of up-to-both beamed xtup
+c that starts with blank rests (notes in upper voice here).
+c
+ if (nbrests.gt.0 .and. writebrests) then
+ do 7 isk = 1 , nbrests
+ notexq = notexq(1:lnote)//chax(92)//'sk'
+ lnote = lnote+3
+7 continue
+ nbrests = 0
+ end if
+c
+c Get 'floor' zmin for figures
+c Note: Will not come thru here on 1st note of unbeamed xtup, so figure height
+c won't be adjusted. If anyone ever needs that, need to duplicate this
+c functionality up above, before exiting.
+c
+ if (figbass .and. (ivx.eq.1 .or. ivx.eq.ivxfig2)) then
+ if (ivx .eq. 1) then
+ ivf = 1
+ else
+ ivf = ivxfig2
+ end if
+ zmult = 1.2*(multb-1)
+ ymin = 100.
+ do 3 inb = 1, nnb
+ if (isfig(ivf,ipb(inb))) then
+ if (ulq(iv,ibc) .eq. 'u') then
+ ybot = nolev(iv,ipb(inb))
+ else
+ ybot = islope(ivx)/slfac*xelsk(inb)+nolev1(ivx)
+ * -stemlen-zmult
+ end if
+ ymin = min(ymin,ybot)
+ end if
+3 continue
+ maxdrop = ncmid(iv,ipb1)-4-ymin+5.01
+ ifigdr(ivf,iline) = max(ifigdr(ivf,iline),maxdrop)
+ end if
+c
+c Compute ornament levels if needed
+c
+ NomOrnLev = ncmid(iv,ipb1)+5
+ iorn = 0
+ do 8 inb = 1 , nnb
+ ip = ipb(inb)
+ if (.not.btest(iornq(ivx,ip),23)) go to 8
+ if (btest(irest(ivx,ip),26) .and. ulq(ivx,ibc).eq.'l') then
+c
+c letter-dynamic or hairpin ending under down-beamed
+c
+ iorn = iorn+1
+ ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1
+ * -1.2*(multb-1)
+ ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10)
+ else if (.not.btest(ipl(ivx,ip),10)) then
+c
+c Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F
+c 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD
+c
+c Non-chord. There IS an ornament. Need ihornb only if upbeam, and if
+c ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.)
+c
+ if (ulq(ivx,ibc).eq.'u' .and.
+ * iand(iornq(ivx,ipb(inb)),4163566).gt.0) then
+ iorn = iorn+1
+ iornq(ivx,ip) = ibset(iornq(ivx,ip),22)
+ ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1
+ * +1.2*(multb-1)
+ ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev)
+ end if
+ else
+c
+c In a chord. Orn may be on main note or non-main or both. Set ihornb if
+c upbeam and highest note has orn, or down beam and lowest. Find 1st chord note
+c
+ do 10 icrd1 = 1 , ncrd
+ if (iand(255,icrdat(icrd1)) .eq. ip .and.
+ * iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 11
+10 continue
+11 continue
+c
+c Find outermost note, min or max depending on beam direction ulq. xto is true
+c if there's an ornament on that note. Expand orn list to include ._, since if
+c on extreme chord note in beam, will move.
+c So ornaments are all except 0,4,13 (,g,)
+c
+ levx = nolev(ivx,ip)
+ xto = iand(iornq(ivx,ipb(inb)),4186094).gt.0
+ icrdx = 0
+ do 12 icrd = icrd1 , ncrd
+ if (iand(255,icrdat(icrd)) .ne. ip .or.
+ * iand(15,ishft(icrdat(icrd),-8)) .ne. ivx) go to 13
+ levc = iand(127,ishft(icrdat(icrd),-12))
+ if ((ulq(ivx,ibc).eq.'u'.and.levc.gt.levx) .or.
+ * (ulq(ivx,ibc).eq.'l'.and.levc.lt.levx)) then
+ levx = levc
+ icrdx = icrd
+ xto = iand(icrdorn(icrd),4186094).gt.0
+ end if
+12 continue
+13 continue
+c
+c If there's orn on extreme note, do stuff
+c
+ if (xto) then
+ iorn = iorn+1
+ if (ulq(ivx,ibc) .eq. 'u') then
+ ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1
+ * +1.2*(multb-1)
+ ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev)
+ else
+ ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1
+ * -1.2*(multb-1)
+ ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10)
+ end if
+ if (icrdx .eq. 0) then
+c
+c Affected ornament is on main note
+c
+ iornq(ivx,ip) = ibset(iornq(ivx,ip),22)
+ else
+ icrdorn(icrdx) = ibset(icrdorn(icrdx),22)
+ end if
+ end if
+ end if
+8 continue
+c
+c Henceforth nornb will be a counter.
+c
+ if (iorn .gt. 0) nornb(ivx)=1
+ if (ixrest(ivx) .eq. 2) ixrest(ivx) = 0
+ return
+ end
+ block data
+ parameter (nm=24)
+ common /comtol/ tol
+ common /comtrans/ cheadq
+ common /compage/ widthpt,ptheight,hoffpt,voffpt,
+ * nsyst,nflb,ibarflb(0:40),
+ * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
+ * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30),
+ * nistaff(0:40)
+ common /cblock/
+ * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
+ * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh
+ common /cominbot/ inbothd
+ logical usefig
+ common /comstart/ facmtr
+ character*60 cheadq
+ character*120 instrq,titleq,compoq
+ logical headlog
+ common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
+ * inhead
+ common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
+ * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
+ * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
+ * rtshfac
+ common /combmh/ bmhgt,clefend
+ common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
+ * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
+ * idynda2(99),levhssav(nm),listcresc,listdecresc
+ character*128 txtdynq
+ logical kbdrests
+ common /comkbdrests/ levbotr(8),levtopr(8),kbdrests
+ common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
+ * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
+ logical EarlyTransOn,LaterInstTrans
+ common /comsize/ isize(nm)
+c
+ data tol /.001/
+ data cheadq
+ * /' '/
+ data gslfac /9./
+ data instrq,titleq,compoq,headlog /3*' ',.false./
+c
+c meter space (pts) = xb4mbr = musicsize*facmtr
+c
+ data facmtr /0.55/
+ data grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
+ * flagfac,dotfac,bacfac,agc1fac,clefend,bmhgt
+ * / 1.3333,.4 , .7 , .3 , 0.2 , 2.0 , 1.0 ,
+ * .7,.7 ,.9 ,.5 ,2.3 ,1.1 /
+ data rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,arpfac
+ * / 1.32 , 2.25 , 0.47 , 0.83 , 0.17 , 0.5 , 1.7 /
+ data rtshfac / 1.0 /
+ data isize /nm*0/
+c
+c From other
+c
+ data ptheight,widthpt,hoffpt,voffpt,
+ * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
+ * xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh
+ * / 740. , 524. , 0., 0.,
+ * .50 , .25 , 0.4 , 0.4 , 0.2 , 12. ,21. , 12.,
+ * 4 , 1.6 ,5.,5.7,1.071,2.714,16 ,16 /
+ data fracsys /30*0./
+ data ivowg,hoh1,hoh2,hoh2h1 /0,0,0,0,0,1,1,1,1,1,1,1,
+c * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6,
+ * 2.2,1.7,1.2,0.7,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6,
+ * -2.7,-2.2,-1.7,-1.2,-2.3,-2.1,-1.0,-1.7,-2.1,-1.6,-1.9,-2.3,
+ * -0.3,0.3 /
+ data kbdrests /.false./,
+ * levtopr /9,7,5,5,7,5,6,6/, levbotr /0,0,0,2,1,4,5,4/
+ data EarlyTransOn, LaterInstTrans /2*.false./
+ data iInstTrans /nm*0/
+ data iTransAmt /nm*0/
+ end
+ subroutine catspace(space,squez,nnsk)
+ parameter (nkb=3999,maxblks=9600)
+ common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
+ * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
+ * ibaroff,udsp(nkb),wheadpt,sqzb(maxblks)
+ common /comtol/ tol
+ do 16 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1
+ if (abs(space-durb(iptr)) .lt. tol) then
+ if (abs(squez-sqzb(iptr)) .lt. tol) then
+c
+c Increment pre-existing entry
+c
+ nnpd(iptr) = nnpd(iptr)+nnsk
+ return
+ end if
+ end if
+16 continue
+c
+c Didn't find current duration & squez, so add a new entry.
+c No particular reason to keep in order, so add at the end.
+c
+ nnpd(nptr(ibarcnt+1)) = nnsk
+ durb(nptr(ibarcnt+1)) = space
+ sqzb(nptr(ibarcnt+1)) = squez
+ nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
+ return
+ end
+ character*1 function chax(n)
+c
+c The only reason for this seemingly do-nothing function is to get around an
+c apparent bug in the Visual Fortran Standard Edition 5.0.A compiler!
+c
+ chax = char(n)
+ return
+ end
+ subroutine checkdyn(lineq,iccount,ibar)
+ character*128 lineq
+ character*1 durq,chax
+ character*4 dynsymq
+ logical txtdyn
+ txtdyn = .false.
+c
+c On entry, iccount is on "D"
+c
+ if (lineq(iccount+1:iccount+1) .eq. chax(34)) then
+c
+c Dynamic text
+c
+
+ istart = iccount+2 ! 1 past 1st quote
+3 continue
+ iend = index(lineq(istart:128),chax(34))
+ if (lineq(istart+iend-2:istart+iend-2) .eq. chax(92)) then
+ istart = iccount+iend+2
+ go to 3
+ end if
+ if (iend .eq. 0) then
+ call errmsg(lineq,iccount+1,ibar,
+ * 'Dynamic text must be terminated with double quote!')
+ call stop1()
+ end if
+c
+c Set iccount to character after 2nd ", and set ipm
+c
+c iccount = iccount+iend+2
+ iccount = istart+iend
+ ipm = index('- +',lineq(iccount:iccount))
+ if (ipm .eq. 0) then
+ call errmsg(lineq,iccount,ibar,
+ * 'Expected "-", "+", or blank here!')
+ call stop1()
+ end if
+ else
+c
+c Expect ordinary dynamic
+c
+ do 1 iend = iccount+2 , 128
+ ipm = index('- +',lineq(iend:iend))
+ if (ipm .gt. 0) go to 2
+1 continue
+2 continue
+ if (iend-iccount.gt.5 .or. iend-iccount.lt.2) then
+ call errmsg(lineq,iend-1,ibar,
+ * 'Wrong length for dynamic mark!')
+ call stop1()
+ end if
+ read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')')
+ * dynsymq
+ idno = (index(
+ * 'ppppppp pp p mp mf f fp sfz ff fff ffff< > ',
+ * dynsymq)+3)/4
+ if (idno .eq. 0) then
+ call errmsg(lineq,iccount+1,ibar,'Illegal dynamic mark!')
+ call stop1()
+ end if
+ iccount = iend
+ end if
+ if (ipm .ne. 2) then
+c
+c There is a vertical shift, have "+" or "-"
+c
+ iccount = iccount+1
+ if (index('0123456789',lineq(iccount:iccount)) .eq. 0) then
+ call errmsg(lineq,iccount,ibar,
+ * 'Expected integer here for vertical offset!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ idno = nint(fnum)
+ if (idno .gt. 63) then
+ call errmsg(lineq,iccount-1,ibar,
+ * 'Vertical offset for dynamic mark must be (-63,63)!')
+ call stop1()
+ end if
+ ipm = index('- +',durq)
+ if (ipm .eq. 0) then
+ call errmsg(lineq,iccount,ibar,
+ * 'Expected "+", "-", or blank here!')
+ call stop1()
+ end if
+ if (ipm .ne. 2) then
+c
+c There is a horizontal shift
+c
+ iccount = iccount+1
+ if (index('.0123456789',lineq(iccount:iccount)) .eq. 0) then
+ call errmsg(lineq,iccount,ibar,
+ * 'Expected number here for horizontal offset!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ idno = nint(10*fnum)
+ if (idno .gt. 255) then
+ call errmsg(lineq,iccount-1,ibar,
+ * 'Horizontal offset for dynamic mark must be (-25.5,25.5)!')
+ call stop1()
+ else if (durq .ne. ' ') then
+ call errmsg(lineq,iccount,ibar,
+ * 'There should be a blank here!')
+ call stop1()
+ end if
+ end if
+c
+c iccount should be on the blank at the end of the entire symbol
+c
+ end if
+ return
+ end
+ subroutine chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp)
+c subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp,
+c * icashft)
+ logical found1,iscacc,isarp,btest
+ integer icrdat(193)
+ found1 = .false.
+c
+c icashft will be max left shift of accid's in chord notes.
+c Used only for spacing checks.
+c Will include left shift of chord note itself.
+c Rezero after use.
+c
+ do 18 icrd = 1 , ncrd
+c
+c This if block cycles thru all chord notes on ivx,ip; then returns.
+c
+ if (iand(255,icrdat(icrd)) .eq. ip .and.
+ * iand(15,ishft(icrdat(icrd),-8)) .eq. ivx) then
+ found1 = .true.
+ iscacc = iscacc .or.
+ * (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27))
+c
+c Accid on this chord note, and it's not midi-only.
+c
+c irshft = igetbits(icrdot(icrd),7,20)
+cc
+cc Include increment for notehead shift
+cc
+c if (btest(icrdat(icrd),23)) then
+c if (irshft .eq. 0) then
+c irshft = 44
+c else
+c irshft=irshft-20
+c end if
+c end if
+c if (irshft .ne. 0) then
+cc
+cc Accid on chord note is shifted. Include only left shift, in 20ths.
+cc
+c if (irshft .lt. 64) icashft = max(icashft,64-irshft)
+c end if
+c end if
+ isarp = isarp .or. btest(icrdat(icrd),25)
+ else if (found1) then
+ return
+ end if
+18 continue
+ return
+ end
+ subroutine chkimidi(icm)
+ parameter (nm=24,mv=24576)
+ integer*2 mmidi
+ logical restpend,relacc,notmain,twoline,ismidi,crdacc
+ common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
+ * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
+ * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
+ * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
+ * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
+ * debugmidi
+ logical debugmidi
+ if (imidi(icm) .ge. mv) then
+ print*
+ print*,'Midi file is too long! It will be corrupted or worse'
+ write(*,'(a6,2x,4i8)')
+ * 'imidi:',imidi(0),imidi(1),imidi(2),imidi(3)
+ end if
+ return
+ end
+ subroutine chkkbdrests(ip,iv,ivx,nn,islur,irest,nolev,ivmx,
+c * nib,nv,ibar,tnow,tol,nodur,mode,levtopr,levbotr,mult)
+ * nib,nv,ibar,tnow,tol,nodur,mode,levtopr,levbotr,mult,ipl)
+ parameter (nm=24)
+ integer*4 nn(nm),islur(nm,200),irest(nm,200),
+ * nolev(nm,200),nib(nm,15),nodur(nm,200),levbotr(8),levtopr(8),
+ * ivmx(nm,2),mult(nm,200),ipl(nm,200)
+c
+c On 130127 put this code, formerly in make2bar right before calling notex for
+c a single note/rest, into this subroutine, so the same logic could also be
+c with the calls to beamstrt/mid/end to adjust height of rests in xtups if the
+c keyboard rest option is selected
+c
+c mode=1 if called as before, 2 if for an xtup. Only affects check for
+c quarter rests, which will fix later.
+c
+c Get reference level: next following note if no intervening blank rests,
+c otherwise next prior note. Relative to bottom line.
+c
+c if (ip.ne.nn(ivx).and..not.btest(iornq(ivx,ip),30)) then
+ if (ip.ne.nn(ivx).and..not.btest(ipl(ivx,ip),1)) then
+c
+c Not the last note and not "look-left" for level
+c
+ do 8 kkp = ip+1 , nn(ivx)
+ if (btest(islur(ivx,kkp),29)) go to 4
+ if (.not.btest(irest(ivx,kkp),0)) then
+ levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line
+ go to 9
+ end if
+8 continue
+ end if
+4 continue
+c
+c If here, there were no following notes or came to a blank rest, or
+c "look-left" option set. So look before
+c
+c if (ip .eq. 1) go to 2 ! Get out if this is the first note.
+ if (ip .eq. 1) return ! Get out if this is the first note.
+ do 3 kkp = ip-1, 1, -1
+ if (.not.btest(irest(ivx,kkp),0)) then
+ levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line
+ go to 9
+ end if
+3 continue
+c go to 2 ! Pretty odd, should never be here, but get out if so.
+ return ! Pretty odd, should never be here, but get out if so.
+9 continue
+c
+c Find note in other voice at same time
+c
+ iupdown = sign(1,ivx-nv-1)
+ ivother = ivmx(iv,(3-iupdown)/2)
+ tother = 0.
+ do 5 kkp = 1 , nib(ivother,ibar)
+ if (abs(tother-tnow) .lt. tol) go to 6
+ tother = tother+nodur(ivother,kkp)
+5 continue
+c
+c If here, then no note starts in other voice at same time, so set default
+c
+ levother = -iupdown*50
+ go to 7
+6 continue
+c
+c If here, have just identified a simultaneous note or rest in other voice
+c
+ if (.not.btest(irest(ivother,kkp),0)) then ! Not a rest, use it
+ levother = nolev(ivother,kkp)-ncmid(iv,ip)+4
+ else
+ if (nodur(ivother,kkp) .eq. nodur(ivx,ip)) then
+c
+c Rest in other voice has same duration, get out (so defualt spacing is used)
+c
+c go to 2
+ return
+ end if
+ levother = -iupdown*50
+ end if
+7 continue
+ if (mode.eq.1) then
+ indxr = log2(nodur(ivx,ip))+1
+ else
+c nodu = 2**(4-(iand(mult(ivx,ip),15)-8))
+ indxr = 4-(iand(mult(ivx,ip),15)-8)+1
+ end if
+ if (iupdown .lt. 0) then
+ levtop = levtopr(indxr)
+ iraise1 = levother-levtop-3 ! Based on other note
+ iraise2 = levnext-levtop ! Based on following note
+ if (indxr.eq.5 .and. levnext.lt.1) iraise2=iraise2+2
+ iraise = min(iraise1,iraise2)
+ if (mod(iraise+50,2).eq.1 .and.
+ * iraise+levtop.gt.-1) iraise = iraise-1
+ else
+ levbot = levbotr(indxr)
+ iraise1 = levother-levbot+3
+ iraise2 = levnext-levbot
+ if (indxr.eq.5 .and. levnext.gt.8) iraise2=iraise2-1
+ iraise = max(iraise1,iraise2)
+ if (mod(iraise+50,2).eq.1 .and.
+ * iraise+levbot.le.9) iraise = iraise-1
+ end if
+ nolev(ivx,ip) = 100+iraise
+ return
+ end
+ subroutine chklit(lineq,iccount,literr)
+ character*128 lineq
+ character*1 charq,chax
+ literr = 0
+ itype = 1
+17 call g1etchar(lineq,iccount,charq)
+ if (charq .eq. chax(92)) then
+ itype = itype+1
+ if (itype .gt. 3) then
+ literr = 1
+ return
+ end if
+ go to 17
+ end if
+ lenlit = itype
+18 call g1etchar(lineq,iccount,charq)
+ if (charq.eq.chax(92)) then
+ call g1etchar(lineq,iccount,charq)
+ if (charq .ne. ' ') then
+c
+c Starting a new tex command withing the string
+c
+ lenlit = lenlit+2
+ if (lenlit .gt. 128) then
+ literr = 2
+ return
+ end if
+ go to 18
+ end if
+ else
+ lenlit = lenlit+1
+ if (lenlit .gt. 128) then
+ literr = 2
+ return
+ end if
+ go to 18
+ end if
+ return
+ end
+ subroutine chkpm4ac(lineq,iccount,nacc,moved)
+c
+c Called after getting +/-/</> in a note (not rest). iccount is on the +-<>.
+c Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits
+c 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed
+c numbers. If moved=.true., iccount on exit is on end of last number.
+c If moved=.false., iccount still on +/-
+c
+ logical moved,ishorz
+ character*128 lineq
+ character*1 durq
+ if (index('sfnA',lineq(iccount-1:iccount-1)).gt.0 .and.
+ * index('0123456789.',lineq(iccount+1:iccount+1)).gt.0) then
+c
+c Prior char was accid & next is #; this may be start of accidental shift.
+c Must test for "." above in case we get "<" or ">"
+c
+ ipm = index('- +< >',lineq(iccount:iccount))-2
+ if (lineq(iccount+1:iccount+1).eq.'.' .and.
+ * index('0123456789',lineq(iccount+2:iccount+2)).eq.0) then
+c
+c Rare case of [accid][+/-].[letter]. Bail out
+c
+ moved = .false.
+ return
+ end if
+ ishorz = ipm .gt. 1
+c
+c Save iccount in case it's not accid shift and we have to reset.
+c
+ icsav = iccount
+ iccount = iccount+1
+ call readnum(lineq,iccount,durq,fnum)
+ if (ishorz .or. index('+-',durq).gt.0) then
+c
+c This has to be accidental shift. Set vert. shift.
+c
+ if (.not.ishorz) then
+c
+c +/- syntax, both shifts set, vertical first
+c
+ call setbits(nacc,6,4,int(ipm*fnum+32.5))
+ ipm = index('- +',durq)-2
+ iccount = iccount+1
+ call readnum(lineq,iccount,durq,fnum)
+ else
+c
+c </> syntax, only horiz set
+c
+ ipm = ipm-3
+ end if
+c
+c Set horiz. shift
+c
+ call setbits(nacc,7,10,nint(20*(ipm*fnum+5.35)))
+ iccount = iccount-1
+ moved = .true.
+ else
+c
+c False alarm. Reset everything and flow onward
+c
+ moved = .false.
+ iccount = icsav
+ end if
+ else
+c
+c Either prior char was not 'sfn' or next was not digit, so take no action
+c
+ moved = .false.
+ end if
+ return
+ end
+ subroutine clefsym(isl,notexq,lnote,nclef)
+c
+c Returns string calling Don's TeX macro \pmxclef, for drawing small clefs.
+c
+ character*(*) notexq
+ character*1 chax
+ nclef = iand(ishft(isl,-12),7)
+ if (nclef .eq. 0) then
+c
+c treble
+c
+ nlev = 2
+ else if (nclef .gt. 6) then
+c
+c French violin
+c
+ nlev = 0
+ else if (nclef .lt. 5) then
+c
+c C-clef
+c
+ nlev = 2*nclef-2
+ else
+c
+c F-clef
+c
+ nlev = 2*nclef-6
+ end if
+ notexq = chax(92)//'pmxclef'//chax(48+min(nclef,7))
+ * //chax(48+nlev)
+ lnote = 10
+ return
+ end
+ subroutine crdacc(nacc,naccid,micrd,nolevm,rmsshift,lasttime,
+ * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
+c
+c nacc = accidental bitmap for main note
+c naccid = # of accid's in chord
+c micrd = array with icrd #'s for notes w/ acc's, 0=>main note
+c nolevm = level of main note
+c segrb(1|2,.) x|y-coord of right-bdry segment
+c ksegrb(.) internal use; tells what defined this segment
+c -2: Left-shifted notehead
+c -1: Original right boundary
+c 0: Main note accidental
+c icrd: Chord-note accidental
+c isetshft(i),i=1,naccid: what set shift for this accid, same codes
+c icrdot0 = top-down level-rank of main note among accid-notes
+c icrdot(icrd)(27-29) = level rank of chord-note among accid-notes
+c twooftwo will be true 2nd time thru; signal to store shifts w/ notes
+c
+ common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
+ * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
+ * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
+ real*4 segar(5,2,6),segal(5,2,6),segrb(2,50),segrb0(2,50)
+ integer*4 nsegar(5),nsegal(5),micrd(10),iacctbl(6),ksegrb(50),
+ * isetshft(10),ksegrb0(50)
+ logical lasttime,mainnote,twooftwo
+ data nsegar / 3,4,3,3,2 /, nsegal / 2,4,3,3,2 /
+ data segar /
+c
+c Fancy sharp boundary. fl,sh,na,dfl,dsh
+c
+ * -0.05,-0.38,-0.34,-.05, -.15,-1.4,-2.9,-3.0, -1.4, -1.2,
+c * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. ,
+c meas value for y, natural is 1.6
+ * -0.75,-0.20,-0.80,-.75, 0. , .96,-1.04,1.48, .96, 1.2,
+ * 0.00,-0.38, 0.00, 0. , 0. ,3.15, 1.64,3.0, 3.15, 0. ,
+ * 0. , 0.00, 0. , 0. , 0. , 0. , 2.90, 0. , 0. , 0. ,
+ * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. ,
+ * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. /
+ data segal /
+c * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. ,
+cc (meas. value is 3.08) ^^^^
+cc Raise top of flat so it interferes with bottom of sharp
+ * -1.00,-1.02,-0.60,-1.65, -1.2,-1.4,-2.9, -3.0, -1.4, -1.2,
+ * 0.00,-1.20,-1.04, 0. , 0. ,3.15,-1.64,-1.48,3.15, 1.2,
+ * 0. ,-1.02, 0.00, 0. , 0. , 0. , 1.04, 3.0, 0. , 0. ,
+ * 0. , 0.00, 0. , 0. , 0. , 0. , 2.9 , 0. , 0. , 0. ,
+ * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. ,
+ * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. /
+c
+c iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6)
+c
+ data iacctbl / 1 , 2 , 3 , 0 , 4 , 5 /
+c
+c Set up barrier segrb(iseg,ipoint) to define coords of corner points
+c on stem+notes
+c
+ do 11 iseg = 1 , nsegrb0
+ segrb(1,iseg) = segrb0(1,iseg)
+ segrb(2,iseg) = segrb0(2,iseg)
+ ksegrb(iseg) = ksegrb0(iseg)
+11 continue
+ nsegrb = nsegrb0
+ rmsshift = 0.
+ shiftmin = 1000.
+ do 1 iwa = 1 , naccid
+c
+c Initialize shift for this note
+c
+ shift = 0.
+ mainnote = micrd(iwa).eq.0
+ isetshft(iwa) = -1
+c
+c Get note level and accidental type
+c
+ if (mainnote) then
+ nolev = nolevm
+ iacctype = iacctbl(igetbits(nacc,3,0))
+ else
+ nolev = igetbits(icrdat(micrd(iwa)),7,12)
+ iacctype = iacctbl(igetbits(icrdat(micrd(iwa)),3,20))
+ end if
+c
+c Cycle thru segments on right edge of this accidental
+c
+ do 2 isega = 1 , nsegar(iacctype)-1
+ ybotaseg = nolev+segar(iacctype,2,isega)
+ ytopaseg = nolev+segar(iacctype,2,isega+1)
+c
+c Cycle thru segments of right-hand barrier
+c
+ do 3 isegrb = 1 , nsegrb-1
+c
+c Must find all barrier segments that start below ytopseg & end above ybotseg
+c
+ if (segrb(2,isegrb) .lt. ytopaseg) then
+c
+c Barrier seg starts below top of accid
+c Check if barrier seg ends above bottom of accid
+c
+ if (segrb(2,isegrb+1) .gt. ybotaseg) then
+ if (shift .gt.
+ * segrb(1,isegrb)-segar(iacctype,1,isega)) then
+ shift = segrb(1,isegrb)-segar(iacctype,1,isega)
+c
+c Record the cause of the shift
+c
+ isetshft(iwa) = ksegrb(isegrb)
+ end if
+ end if
+c
+c Does barrier segment end above top of accid seg?
+c
+ if (segrb(2,isegrb+1) .gt. ytopaseg) go to 4
+ end if
+3 continue
+4 continue
+2 continue
+ if (.not.btest(nacc,28) .and. abs(shift).gt.0.0001
+ * .and. .not.lasttime) then
+c if (nolev .eq. levmaxacc) then
+ if (nolev.eq.levmaxacc .and. isetshft(iwa).eq.-1) then
+ rmsshift = 1000.
+ return
+ end if
+c
+c Does the following properly account for left-shifted noteheads?
+c
+c Top-down rank of this note we just shifted
+c
+ if (mainnote) then
+ irank = icrdot0
+ else
+ irank = igetbits(icrdot(micrd(iwa)),3,27)
+ end if
+c
+c Compare level-rank of this note vs. that of note that caused the shift.
+c This has effect of checking for basic interferences from top down.
+c
+c ksegrb(.) internal use; tells what defined this segment
+c -2: Left-shifted notehead
+c -1: Original right boundary
+c 0: Main note accidental
+c icrd: Chord-note accidental
+c isetshft(i),i=1,naccid: what set shift for this accid, same codes
+c
+ if (isetshft(iwa) .lt. 0) then
+ iranksetter = 0
+ else if (isetshft(iwa) .eq. 0) then
+ iranksetter = icrdot0
+ else
+ iranksetter = igetbits(icrdot(isetshft(iwa)),3,27)
+ end if
+ if (iranksetter.ne.0 .and. irank.ne.iranksetter+1) then
+ rmsshift = 1000.
+ return
+ end if
+ end if
+ rmsshift = rmsshift+shift**2
+ if (lasttime .and. abs(shift).gt..0001) then
+ if (mainnote) then
+ if (.not.btest(nacc,29)) go to 10
+ else
+ if (.not.btest(icrdat(micrd(iwa)),29)) go to 10
+ end if
+c
+c If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there
+c was a manual shift but auto-shift was zero, will not come thru here, but shift value
+c will be left intact.
+c
+ if (mainnote) then
+ shift = shift+.05*(igetbits(nacc,7,10)-107)
+ else
+ shift = shift+.05*(igetbits(icrdot(micrd(iwa)),7,20)-107)
+ end if
+10 continue
+ if (twooftwo) then
+c
+c Record the shift for this accidental
+c
+ if (shift .lt. -5.35) then
+ call printl(' ')
+ call printl('WARNING: auto-generated accidental '//
+ * 'shift too big for PMX, ignoring')
+ else
+ ishift = nint(20*(shift+5.35))
+ if (mainnote) then
+ call setbits(nacc,7,10,ishift)
+ else
+ call setbits(icrdot(micrd(iwa)),7,20,ishift)
+ end if
+ end if
+ else
+c
+c This is the earlier call to precrd, so need minimum shift
+c
+ shiftmin = min(shiftmin,shift)
+ end if
+ end if
+c
+c Bail out if this is the last accidental to check
+c
+ if (iwa .eq. naccid) go to 1
+c
+c Add this accidental to the right barrier! Count down from highest barrier segment,
+c find 1st one starting below top of accid, and first one starting below bot.
+c
+ do 5 ibelowtop = nsegrb , 1 , -1
+ if (segrb(2,ibelowtop) .lt.
+ * nolev+segal(iacctype,2,nsegal(iacctype))) then
+ do 9 ibelowbot = ibelowtop , 1 , -1
+ if (segrb(2,ibelowbot) .lt.
+ * nolev+segal(iacctype,2,1)) go to 6
+9 continue
+ print*,'Oops2!'
+ call stop1()
+ end if
+5 continue
+ print*,'Ugh0! in crdaccs'
+ call stop1()
+6 continue
+ netgain = nsegal(iacctype)-ibelowtop+ibelowbot
+c
+c Shift high segments up
+c
+ if (netgain .ge. 0) then
+ do 7 isegrb = nsegrb , ibelowtop+1 , -1
+ segrb(1,isegrb+netgain) = segrb(1,isegrb)
+ segrb(2,isegrb+netgain) = segrb(2,isegrb)
+ ksegrb(isegrb+netgain) = ksegrb(isegrb)
+7 continue
+c
+c Set up 1st segment above accid
+c
+ segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop)
+ segrb(2,ibelowtop+netgain) =
+ * nolev+segal(iacctype,2,nsegal(iacctype))
+ ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop)
+ else
+c
+c netgain<0, must remove segments. Use same coding but reverse order,
+c work from bottom up
+c
+ segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop)
+ segrb(2,ibelowtop+netgain) =
+ * nolev+segal(iacctype,2,nsegal(iacctype))
+ ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop)
+ do 12 isegrb = ibelowtop+1 , nsegrb
+ segrb(1,isegrb+netgain) = segrb(1,isegrb)
+ segrb(2,isegrb+netgain) = segrb(2,isegrb)
+ ksegrb(isegrb+netgain) = ksegrb(isegrb)
+12 continue
+ end if
+c
+c Insert new segments
+c
+ do 8 isega = 1 , nsegal(iacctype)-1
+ segrb(1,ibelowbot+isega) = shift+segal(iacctype,1,isega)
+ segrb(2,ibelowbot+isega) = nolev+segal(iacctype,2,isega)
+ if (mainnote) then
+ ksegrb(ibelowbot+isega) = 0
+ else
+ ksegrb(ibelowbot+isega) = micrd(iwa)
+ end if
+8 continue
+c
+c Update number of barrier segments
+c
+ nsegrb = nsegrb+netgain
+cc
+cc Temporary printout for boundary segments as built up
+cc
+c write(15,'()')
+c write(15,'(a/(2f8.2,i5))')' y x kseg',
+c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb)
+c write(15,'(a/(2i5))')' micrd isetshft',
+c * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa)
+cc
+1 continue ! next accidental
+ if (lasttime .and. .not.twooftwo) then
+c
+c This is the final call on the pre-ask pass, so compute left-shift rqmt.
+c
+ icashft = nint(-20*shiftmin)
+ end if
+cc
+cc Temporary printout for boundary segments
+cc
+c if (twooftwo) then
+c write(15,'()')
+c write(15,'(a/(2f8.2,i5))')' y x kseg',
+c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb)
+c write(15,'(a/(2i5))')' micrd isetshft',
+c * (micrd(iwa),isetshft(iwa),iwa=1,naccid)
+c end if
+cc
+ return
+ end
+ subroutine crdaccs(nacc,ipl,irest,naccid,kicrd,nolevm,
+ * levmaxacc,levminacc,icrdot0,twooftwo,icashft)
+c
+c nacc = accidental bitmap for main note
+c naccid = # of accid's in chord
+c kicrd = array with icrd #'s for notes w/ acc's, 0=>main note
+c nolevm = level of main note
+c
+c This is called once per multi-accidental chord. In here, loop over all
+c permutations of the order of accidental as stored in kicrd. Each time thru
+c loop, call crdacc once, get rms shift. Only save permutation and rms value
+c if it is less than old value.
+c
+ common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
+ * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
+ * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
+c
+c Make consistent? 120106
+c integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50)
+ integer*4 kicrd(10),iperm(7),micrd(10),ipermsav(7),ksegrb0(50)
+ real*4 segrb0(2,50)
+ logical btest,tagged,manual,lshift,twooftwo
+cc
+cc Temporary printout of level-rankings
+cc
+c write(15,'()')
+c do 98 iacc = 1 , naccid
+c if (kicrd(iacc) .eq. 0) then
+c write(15,'(3i5)')nolevm,icrdot0
+c else
+c write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12),
+c * igetbits(icrdot(kicrd(iacc)),3,27)
+c end if
+c98 continue
+cc
+c
+c Initialize right-barrier
+c
+ segrb0(1,1) = 0.
+ segrb0(2,1) = -1000.
+ segrb0(1,2) = 0.
+ segrb0(2,2) = 1000.
+ nsegrb0 = 2
+ ksegrb0(1) = -1
+ ksegrb0(2) = -1
+c
+c Search for left-shifted notes, Make up the initial right-barrier, which
+c will be good for all permutations.
+c irest()(27) is set if any notes are left-shifted
+c Must use ALL chord notes, not just ones w/ accid's.
+c
+ if (btest(irest,27)) then
+ do 15 icrd = icrd1-1, icrd2
+ if (icrd .eq. icrd1-1) then
+c
+c Main note
+c
+c lshift = btest(ipl,8)
+ lshift = btest(ipl,8) .or. btest(nacc,31)
+ if (lshift) nolev = nolevm
+ else
+c
+c Chord note
+c
+ lshift = btest(icrdat(icrd),23)
+c if (lshift) nolev = igetbits(icrdat(icrd),7,12)
+ if (lshift) then
+ nolev = igetbits(icrdat(icrd),7,12)
+ if (btest(nacc,31) .and. nolev.eq.nolevm+1) then
+c
+c This note is not really shifted, It is the upper of a 2nd with the main
+c note on an upstem, and Main note must be shifted.
+c nacc(31) signals the real truth.
+c
+ lshift = .false.
+ end if
+ end if
+ end if
+ if (lshift) then
+ do 16 isegrb = 1 , nsegrb0-1
+ if (segrb0(2,isegrb+1) .gt. nolev-1) then
+c
+c Add this notehead to the right boundary here. Move all higher segs up 2.
+c
+ do 17 iiseg = nsegrb0 , isegrb+1 , -1
+ segrb0(1,iiseg+2) = segrb0(1,iiseg)
+ segrb0(2,iiseg+2) = segrb0(2,iiseg)
+ ksegrb0(iiseg+2) = ksegrb0(iiseg)
+17 continue
+ go to 18
+ end if
+16 continue
+18 continue
+c
+c Insert notehead into list. Set kseg=-2 to signal notehead shift.
+c
+ iiseg = isegrb+1
+ segrb0(1,iiseg) = -1.2
+ segrb0(2,iiseg) = nolev-1.
+ ksegrb0(iiseg) = -2
+ segrb0(1,iiseg+1) = 0.
+ segrb0(2,iiseg+1) = nolev+1.
+ ksegrb0(iiseg+1) = -1
+ nsegrb0 = nsegrb0+2
+ end if
+15 continue
+ end if
+c
+c Done setting right barrier for left-shifted noteheads
+c
+ tagged = .false.
+ manual = .false.
+c
+c Preprocess to check for manual shifts.
+c If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then
+c If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then
+c 1. Auto-shifting proceeds
+c 2. "A"-shifts add to autoshifts
+c 3. non-"A" shifts are ignored!
+c Else (>0 man shifts, none has "A")
+c No auto-ordering, No autoshifts, Observe all manual shifts.
+c End if
+c End if
+c
+ maxmanshft = 0
+ do 13 i = 1 , naccid
+ if (kicrd(i) .eq. 0) then
+c
+c Main note
+c
+ manshft = igetbits(nacc,7,10)
+ if (manshft .ne. 0) then
+ manual = .true.
+ if (btest(nacc,29)) then
+ tagged = .true.
+ else
+c maxmanshft = max(maxmanshft,64-manshft)
+ maxmanshft = max(maxmanshft,107-manshft)
+ end if
+ end if
+ else
+c
+c Chord note
+c
+ manshft = igetbits(icrdot(kicrd(i)),7,20)
+ if (manshft .ne. 0) then
+ manual = .true.
+ if (btest(icrdat(kicrd(i)),29)) then
+ tagged = .true.
+ else
+c maxmanshft = max(maxmanshft,64-manshft)
+ maxmanshft = max(maxmanshft,107-manshft)
+ end if
+ end if
+ end if
+13 continue
+ if (manual) then
+ if (tagged) then
+c
+c zero out all untagged shifts
+c
+ do 14 i = 1 , naccid
+ if (kicrd(i) .eq. 0) then
+ if (.not.btest(nacc,29)) call setbits (nacc,7,10,0)
+ else
+ if (.not.btest(icrdat(kicrd(i)),29))
+ * call setbits (icrdot(kicrd(i)),7,20,0)
+ end if
+14 continue
+ else
+c
+c There are manual shifts but none tagged. Only proceed if "Ao" was entered
+c
+ if (.not.btest(nacc,28)) then
+ icashft = maxmanshft
+ return
+ end if
+ end if
+ end if
+ if (btest(nacc,28)) then
+c
+c Take the accidentals in order as originally input, then exit.
+c
+ call crdacc(nacc,naccid,kicrd,nolevm,rmsshift,.true.,
+ * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
+ return
+c end if
+ else if (naccid .eq. 3) then
+c
+c Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd
+c then place in order top, bottom, middle.
+c
+ do 20 i = 1 , 3
+ if (kicrd(i) .eq. 0) then
+ irank = icrdot0
+ nolev = nolevm
+ else
+ irank = igetbits(icrdot(kicrd(i)),3,27)
+ nolev = igetbits(icrdat(kicrd(i)),7,12)
+ end if
+ if (irank .eq. 1 ) then
+ micrd(1) = kicrd(i)
+ else
+ micrd(5-irank) = kicrd(i)
+ end if
+ if (irank .eq. 2) then
+ levmidacc = nolev
+ end if
+20 continue
+ if (levmaxacc.ne.levmidacc+1 .and.
+ * levmidacc.ne.levminacc+1) then
+ call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true.,
+ * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
+ return
+ end if
+ end if
+ rmsmin = 100000.
+c
+c Initialize permutation array
+c
+ do 7 i = 1 , naccid
+ iperm(i) = i
+7 continue
+c
+c Start looping over permutations
+c
+ do 8 ip = 1 , 5041
+ if (ip .ne. 1) then
+c
+c Work the magic algorithm to get the next permutation
+c
+ do 1 k = naccid-1 , 1 , -1
+ if (iperm(k) .le. iperm(k+1)) go to 2
+1 continue
+c
+c If here, we just got the last permutation, so exit the loop over permutations
+c
+ go to 10
+2 continue
+ do 3 j = naccid , 1 , -1
+ if (iperm(k) .le. iperm(j)) go to 4
+3 continue
+4 continue
+ it = iperm(j)
+ iperm(j) = iperm(k)
+ iperm(k) = it
+ is = k+1
+ do 5 ir = naccid , 1 , -1
+ if (ir .le. is) go to 6
+ it = iperm(ir)
+ iperm(ir) = iperm(is)
+ iperm(is) = it
+ is = is+1
+5 continue
+6 continue
+ end if
+c
+c New we have a permutation. Take icrd values out of kicrd and put them into
+c micrd in the order of the permutation
+c
+ do 9 i = 1 , naccid
+ micrd(i) = kicrd(iperm(i))
+9 continue
+cc
+cc Temporary printout
+cc
+c write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid)
+cc
+ call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.false.,
+ * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
+cc
+cc Temporary printout
+cc
+c write(15,*)'perm done, rmsshift:',rmsshift
+cc
+ if (rmsshift .lt. rmsmin) then
+c
+c Save this permutation, reset minrms
+c
+ do 11 i = 1 , naccid
+ ipermsav(i) = iperm(i)
+ rmsmin = rmsshift
+11 continue
+ end if
+8 continue
+ print*,'Should not BEEEEEE here!'
+ call stop1()
+10 continue
+c
+c Done looping, get info for the final choice
+c
+ do 12 i = 1 , naccid
+ micrd(i) = kicrd(ipermsav(i))
+12 continue
+cc
+cc Temporary printout
+cc
+c write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid)
+cc
+ call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true.,
+ * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
+ return
+ end
+ subroutine doacc(ihshft,ivshft,notexq,lnote,nacc,nolev,ncm,caut)
+ character*1 sq,chax
+ character*3 acsymq
+ character*8 noteq
+ character*79 notexq
+ logical btest,caut
+ sq = chax(92)
+ if (ihshft .eq. -107) ihshft=0
+cc
+cc If main note shifted left, so shift accid. Terminate below, when acc. is done.
+cc
+ if (ihshft .ne. 0) then
+c
+c Accid must be shifted horizontally
+c
+ if (ihshft .lt. 0) then
+ notexq = sq//'loffset{'
+ ihshft = -ihshft
+ else
+ notexq = sq//'roffset{'
+ end if
+ hshft = .05*ihshft
+ if (hshft .lt. 1.) then
+ write(notexq(10:12),'(f3.2)')hshft
+ lnote = 12
+ else
+ write(notexq(10:13),'(f4.2)')hshft
+ lnote = 13
+ end if
+ notexq = notexq(1:lnote)//'}{'//sq
+ lnote = lnote+3
+ else
+ notexq = sq
+ lnote = 1
+ end if
+ if (btest(nacc,3)) then
+ notexq = notexq(1:lnote)//'big'
+ lnote = lnote+3
+ end if
+ if (caut) then
+c
+c Cautionary accidental. Need to define bigcna,... in pmx.tex
+c
+ notexq = notexq(1:lnote)//'c'
+ lnote = lnote+1
+ end if
+ call accsym(nacc,acsymq,lacc)
+ notexq = notexq(1:lnote)//acsymq(1:lacc)
+ lnote = lnote+lacc
+ noleva = nolev
+ if (ivshft .ne. 0) noleva = noleva+ivshft-32
+ call notefq(noteq,lnoten,noleva,ncm)
+ if (lnoten .eq. 1) call addblank(noteq,lnoten)
+ notexq = notexq(1:lnote)//noteq(1:lnoten)
+ lnote = lnote+lnoten
+ if (ihshft .ne. 0) then
+c
+c Terminate horizontal shift
+c
+ notexq = notexq(1:lnote)//'}'
+ lnote = lnote+1
+ end if
+ return
+ end
+ subroutine docrd(ivx,ip,nodu,ncm,iv,tnow,soutq,lsout,ulq,ibmcnt,
+ * islur,nvmx,nv,beamon,nolevm,ihornb,nornb,stemlen,
+ * dotxtup,nacc,irest)
+ parameter (nm=24,mv=24576)
+ integer*4 irest(nm,24)
+ common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
+ * xinsnow,lowdot
+ common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
+ * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
+ * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
+ common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
+ * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
+ * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
+ * rtshfac
+ integer*2 mmidi,iinsiv
+ logical restpend,relacc,notmain,twoline,ismidi,crdacc
+ common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
+ * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
+ * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
+ * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
+ * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
+ * debugmidi
+ logical debugmidi
+ logical lowdot,dotxtup
+ integer*4 ihornb(nm,24),nornb(nm)
+ character*1 ulq(nm,9),chax
+ character*7 nosymq
+ character*8 noteq
+ character*79 notexq,outq
+ character*80 soutq
+ logical btest,isleft,isright,beamon
+ character*79 inameq
+ common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
+ * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig,
+ * lnam(nm),inameq(nm)
+ common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
+ * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
+ logical EarlyTransOn,LaterInstTrans
+ common /commidisig/ midisig
+ common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
+ * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
+ common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
+ * maxdotmv(nm),ndotmv(nm),updot(nm,20),rtdot(nm,20)
+c
+c This subr. once produced notexq for entire chord. 10/18/97 altered to write
+c chord notes as we go. 10/22/97 find range of icrd first.
+c 2/25/98 moved rangefinding to precrd so done before slurs, so now
+c on entry, icrd1, icrd2 define range of icrd for this chord.
+c
+c Set counter (for this note) for chord notes present. Set notmain=T.
+c Will test for notmain=.true. in addmidi to tell whether to save pitch.
+c
+ nmidcrd = 0
+ notmain = .true.
+ crdacc = .false.
+ do 5 icrd = icrd1 , icrd2
+ lnote = 0
+ nolev = igetbits(icrdat(icrd),7,12)
+c
+c 3/8/03 save original pitch to use in midi, in case 2nds alter things.
+c
+ nolevo = nolev
+c
+c Check for special situations with 2nds (see precrd).
+c
+ if (btest(nacc,30) .and. nolev.eq.nolevm-1) then
+c
+c Upstem, 2nd with upper as main, interchange pitches,
+c rt-shift upper (now chord note). Lower (orig chord, now main)
+c if dotted, probably had shifted dot, dot parameters must be moved
+c from chord to main
+c
+ nolev = nolevm
+ if (btest(icrdat(icrd),26)) then
+c
+c Orig. chord note dot shift, must transfer to main.
+c
+ icrdotsav = icrdot(icrd)
+ icrdatsav = icrdat(icrd)
+ if (btest(irest(ivx,ip),19)) then
+c
+c Main note (upper) had a dot shift, must move it to chord
+c
+ call setbits(icrdat(icrd),1,26,1)
+ call setbits(icrdot(icrd),7,0,
+ * nint(updot(ivx,ndotmv(ivx)+1)*10)+64)
+ call setbits(icrdot(icrd),7,7,
+ * nint(rtdot(ivx,ndotmv(ivx)+1)*10)+64)
+c
+c May need to worry about other chord params (accid shefts etc) later
+c
+ else
+ icrdat(icrd) = ibclr(icrdat(icrd),26)
+ end if
+c
+c We are adding a main note dot shift, so push any later ones back
+c
+
+ if (.not.btest(irest(ivx,ip),19)) then
+ maxdotmv(ivx) = maxdotmv(ivx)+1
+ do 1 indm = maxdotmv(ivx) , ndotmv(ivx)+2 , -1
+ updot(ivx,indm) = updot(ivx,indm-1)
+ rtdot(ivx,indm) = rtdot(ivx,indm-1)
+1 continue
+ end if
+ irest(ivx,ip) = ibset(irest(ivx,ip),19)
+ updot(ivx,ndotmv(ivx)+1) = 0.1*(iand(127,icrdotsav)-64)
+ rtdot(ivx,ndotmv(ivx)+1) =
+ * 0.1*(iand(127,ishft(icrdotsav,-7))-64)
+ end if
+ else if (btest(nacc,31) .and. nolev.eq.nolevm+1) then
+c
+c Downstem, 2nd with lower as main, interchange pitches,
+c left-shift lower (now chord note). Lower (orig main, now chord)
+c probably had shifted dot, dot parameters must be moved from
+c main to chord
+c
+ nolev = nolevm
+ if (btest(irest(ivx,ip),19)) then
+ icrdotsav = icrdot(icrd)
+ icrdatsav = icrdat(icrd)
+ icrdat(icrd) = ibset(icrdat(icrd),26)
+c bits in icrdot
+c 0-6 10*abs(vertical dot shift in \internote) + 64
+c 7-13 10*abs(horizontal dot shift in \internote) + 64
+c Assuming >0 for now!
+ call setbits(icrdot(icrd),7,0,
+ * nint(updot(ivx,ndotmv(ivx)+1)*10)+64)
+ call setbits(icrdot(icrd),7,7,
+ * nint(rtdot(ivx,ndotmv(ivx)+1)*10)+64)
+c
+c Must also set dot shift for (now) main note (orig. chord note).
+c
+ if (btest(icrdatsav,26)) then
+ updot(ivx,ndotmv(ivx)+1) = 0.1*(iand(127,icrdotsav)-64)
+ rtdot(ivx,ndotmv(ivx)+1) =
+ * 0.1*(iand(127,ishft(icrdotsav,-7))-64)
+ else
+c
+c No dot move on original chord (now main) note,
+c
+ updot(ivx,ndotmv(ivx)+1) = 0.
+ rtdot(ivx,ndotmv(ivx)+1) = 0.
+ end if
+ end if
+ end if
+c
+c Lower dot for lower-voice notes?. Conditions are:
+c 1. Dotted time value
+c 2. Lower voice of two
+c 3. Note is on a line
+c 4. Not a rest (cannot be a rest in a chord!)
+c. 5. Flag (lowdot) is set to true
+c
+ if (lowdot .and. nvmx.eq.2 .and. ivx.le.nv) then
+ if (2**log2(nodu).ne.nodu .and. mod(nolev-ncm,2).eq.0) then
+ if (btest(icrdat(icrd),26)) then
+c
+c Note already in movdot list. Drop by 2.
+c
+ call setbits(icrdot(icrd),7,0,
+ * igetbits(icrdot(icrd),7,0)-20)
+ else
+c
+c Not in list so just move it right now
+c
+ call dotmov(-2.,0.,soutq,lsout,igetbits(islur,1,3))
+ end if
+ end if
+ end if
+ if (btest(icrdat(icrd),26)) then
+c
+c Move the dot. Basic call for chord notes, not main note.
+c
+ updotc = 0.1*(iand(127,icrdot(icrd))-64)
+ rtdotc = 0.1*(iand(127,ishft(icrdot(icrd),-7))-64)
+ call dotmov(updotc,rtdotc,soutq,lsout,igetbits(islur,1,3))
+ end if
+ isleft = btest(icrdat(icrd),23)
+ isright = btest(icrdat(icrd),24)
+c
+c Check for ornament in chord.
+c
+ if (icrdorn(icrd) .gt. 0) then
+ call putorn(icrdorn(icrd),nolev,nolevm,nodu,nornb,ulq,
+ * ibmcnt,ivx,ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,
+ * ip,0,beamon,.true.)
+ call addstr(outq,lout,soutq,lsout)
+ end if
+c
+c Chord-note symbol. First check for breve
+c
+ if (nodu .eq. 128) then
+ nosymq = chax(92)//'zbreve'
+ lsym = 7
+ else
+c
+c Not a breve chord. Get first letters in chord-note symbol
+c
+ if (isleft) then
+ nosymq = chax(92)//'l'
+ else if (isright) then
+ nosymq = chax(92)//'r'
+ else
+ nosymq = chax(92)//'z'
+ end if
+ if (nodu .ge. 64) then
+ nosymq = nosymq(1:2)//'w'
+ else if (nodu .ge. 32) then
+ nosymq = nosymq(1:2)//'h'
+ else
+ nosymq = nosymq(1:2)//'q'
+ end if
+ if (2**log2(nodu).eq.nodu .and. .not.dotxtup) then
+ lsym = 3
+ else if (.not.btest(islur,3) .or. dotxtup) then
+c
+c Single dot
+c
+ nosymq = nosymq(1:3)//'p'
+ lsym = 4
+ else
+c
+c Double dot
+c
+ nosymq = nosymq(1:3)//'pp'
+ lsym = 5
+ end if
+ end if
+ if (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) then
+c
+c Accidental and not MIDI-only. Build up bits 0-3 of nacc
+c
+ nactmp = igetbits(icrdat(icrd),3,20)
+c
+c Kluge for bigness. Only means 'As' has not been issued
+c
+ if (bacfac .ne. 1.e6) nactmp = nactmp+8
+ call doacc(igetbits(icrdot(icrd),7,20)-107,
+ * igetbits(icrdot(icrd),6,14),
+c * notexq,lnote,nactmp,nolev,ncmid(iv,ip))
+c Get original nolev, not altered to deal with 2nds
+ * notexq,lnote,nactmp,igetbits(icrdat(icrd),7,12),
+c * ncmid(iv,ip))
+ * ncmid(iv,ip),btest(icrdat(icrd),31))
+ notexq = notexq(1:lnote)//nosymq
+ crdacc = .true.
+ else
+ notexq = nosymq
+ end if
+ lnote = lnote+lsym
+c
+c Get note name (again if accid, due to possible octave jump)
+c
+ call notefq(noteq,lnoten,nolev,ncm)
+ if (lnoten.eq.1) call addblank(noteq,lnoten)
+c
+c Put in note name
+c
+ notexq = notexq(1:lnote)//noteq
+ lnote = lnote+lnoten
+ if (btest(icrdat(icrd),25)) then
+c
+c Arpeggio signal
+c
+ call putarp(tnow,ivx,ip,nolev,ncm,soutq,lsout)
+ end if
+ call addstr(notexq,lnote,soutq,lsout)
+ if (ismidi) then
+c
+c Here is where we collect MIDI pitch info for the chord note. By checking
+c notmain, addmidi(...) knows to just compute the
+c pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi()
+c for MAIN note, will put in note codes for all chord notes + main note.
+c
+ kv = 1
+ if (ivx .gt. iv) kv=2
+ nmidcrd = nmidcrd+1
+ if (nmidcrd .gt. 20) then
+ print*
+ print*,'21 chord notes is too many for midi processor'
+ call stop1()
+ end if
+c
+c Use original saved pitch level, unaltered by 2nds logic.
+c
+ call addmidi(midchan(iv,kv),nolevo+miditran(instno(iv)),
+ * igetbits(icrdat(icrd),3,20),midisig,1.,
+ * .false.,.false.)
+ end if
+5 continue
+ notmain = .false.
+ return
+ end
+ subroutine dodyn(ivx,ip,nolev,ncm,ipl,islur,irest,nvmx,nv,
+ * beamon,ihornb,nornb,ulq,ibmcnt,nostem,soutq,lsout)
+ parameter (nm=24)
+c
+c Inputs are array *elements* except ihornb,nornb,ulq
+c
+ common /commus/ musize,whead20
+ common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
+ * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
+ * idynda2(99),levhssav(nm),listcresc,listdecresc
+ character*128 txtdynq
+ common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
+ * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
+ * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
+ logical btest,beamon,upstem,nostem
+ common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
+ * ,WrotePsslurDefaults,SlurCurve
+ logical fontslur,upslur,WrotePsslurDefaults
+ character*1 udqq,chax,ulq(nm,9)
+ character*4 dynstrq
+ character*5 numpq
+ character*48 dyntablq,tempq
+ character*79 notexq
+ character*80 soutq
+ integer*4 ihornb(nm,24),nornb(nm),idynn(10)
+ common /comhair/ ihairuse,idhair(nm)
+ data dyntablq /'ppppppp pp p mp mf f fp sfz ff fff ffff'/
+ numdyn = 0
+c
+c Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values
+c in idynn(1...4)
+c
+ do 1 idyn = 1 , ndyn
+ ivxtent = iand(idyndat(idyn),15)
+ * +16*igetbits(idynda2(idyn),1,10)
+ if (ivxtent .eq. ivx) then
+ iptent = igetbits(idyndat(idyn),8,4)
+ if (iptent .eq. ip) then
+ numdyn = numdyn+1
+ idynn(numdyn) = idyn
+ else if (iptent .gt. ip) then
+c
+c I don't think there are any more possible for this ivx,ip, so exit loop
+c
+ go to 2
+ end if
+ end if
+1 continue
+2 continue
+c
+c At this point there is a list of idyn's in idynn(1...numdyn)
+c Compute level, and stem-dir'n-based horizontal tweaks
+c
+ hoffsd = 0.
+c
+c Set upstem to false as default
+c
+ upstem = .false.
+ if (btest(irest,0)) then
+c
+c It's a rest. Assume it doesn't go below the staff
+c
+ lbot = ncm-4
+ else if (.not.beamon) then
+ if (udqq(nolev,ncm,islur,nvmx,ivx,nv).eq.'u' .or. nostem) then
+ upstem = .true.
+ if (.not.btest(ipl,10)) then
+ lbot = min(nolev-1,ncm-4)
+ else
+ lbot = min(minlev-1,ncm-4)
+ end if
+ else
+ hoffsd = -.5
+ if (.not.btest(ipl,10)) then
+ lbot = min(nolev-7,ncm-4)
+ else
+ lbot = min(minlev-7,ncm-4)
+ end if
+ end if
+ else
+ if (ulq(ivx,ibmcnt) .eq. 'u') then
+ upstem = .true.
+ if (.not.btest(ipl,10)) then
+ lbot = min(nolev-1,ncm-4)
+ else
+ lbot = min(minlev-1,ncm-4)
+ end if
+ else
+ hoffsd = -.5
+c
+c 171230 Desperation
+c lbot = ihornb(ivx,nornb(ivx))+1
+ if (nornb(ivx).eq.0) then
+ lbot = 1
+ else
+ lbot = ihornb(ivx,nornb(ivx))+1
+ end if
+ if (lbot .eq. 1) then
+c
+c Kluge for non-beamed, down xtup, for which ihorb was never set.
+c Assumes stem is shortened.
+c
+ lbot = nolev-5
+ end if
+ nornb(ivx) = nornb(ivx)+1
+ end if
+ end if
+ lbot = lbot-5
+ jtxtdyn1 = 1
+c
+c Now ready to loop over current dyn's
+c
+ do 3 icntdyn = 1 , numdyn
+ idynd = idyndat(idynn(icntdyn))
+ idynd2 = idynda2(idynn(icntdyn))
+ idno = igetbits(idynd,4,12)
+c ivx = iand(15,idynd)
+ ivx = iand(15,idynd)+16*igetbits(idynd2,1,10)
+c
+c Build the command into notex in stages. Insert name & rq'd args in order:
+c
+c Command name
+c hpstrt, hpcend, hpdend, pmxdyn
+c ivx
+c X X X
+c level
+c X X X
+c hoff
+c X X X X
+c d-mark
+c X
+c
+ if (idno .eq. 0) then
+c
+c Text-dynamic
+c
+ notexq = chax(92)//'txtdyn'
+ lnote = 7
+ else if (idno .le. 12) then
+c
+c Letter-group
+c
+ notexq = chax(92)//'pmxdyn'
+ lnote = 7
+ else if (fontslur) then
+ lnote = 7
+ if (idno .eq. 13) then
+c
+c Start a font-based hairpin
+c
+ notexq = chax(92)//'hpstrt'
+ else if (idno .eq. 14) then
+c
+c End crescendo
+c
+ notexq = chax(92)//'hpcend'
+ else
+c
+c End decrescendo
+c
+ notexq = chax(92)//'hpdend'
+ end if
+c
+c Put in voice number as ID for font-based hairpin
+c
+ if (ivx .le. 9) then
+ notexq = notexq(1:lnote)//char(48+ivx)
+ lnote = lnote+1
+ else if (ivx .le. 19) then
+ notexq = notexq(1:lnote)//'{1'//char(38+ivx)//'}'
+ lnote = lnote+4
+ else
+ notexq = notexq(1:lnote)//'{2'//char(28+ivx)//'}'
+ lnote = lnote+4
+ end if
+ else
+c
+c Postscript hairpins
+c
+ lnote = 7
+ if (idno .eq. 13) then
+ notexq = chax(92)//'Icresc'
+ else if (idno .eq.14) then
+ notexq = chax(92)//'Idecresc'
+ lnote = 9
+ else
+ notexq = chax(92)//'Tcresc'
+ end if
+ if (idno .le. 14) then
+c
+c Get and record ID no for start of ps hairpin
+c Find first unused ID
+c
+ do 8 idh = 1 , 24
+ if (.not.btest(ihairuse,idh)) go to 9
+8 continue
+ call printl('Bad place in putdyn, call Dr. Don')
+ call stop1()
+9 continue
+ ihairuse = ibset(ihairuse,idh)
+ idhair(ivx) = idh
+ else
+c
+c Unrecord ID no for end of ps hairpin
+c
+ call setbits(ihairuse,1,idhair(ivx),0)
+ end if
+c
+c Write ID # for start or end of ps hairpin
+c
+ idh = idhair(ivx)
+ if (idh .le. 9) then
+ notexq = notexq(1:lnote)//char(48+idh)
+ lnote = lnote+1
+ else if (idh .le. 19) then
+ notexq = notexq(1:lnote)//'{1'//char(38+idh)//'}'
+ lnote = lnote+4
+ else
+ notexq = notexq(1:lnote)//'{2'//char(28+idh)//'}'
+ lnote = lnote+4
+ end if
+ end if
+c
+c Begin setting level
+c
+ lbot1 = lbot
+ if (idno.gt.0 .and. idno.le.5) then
+c
+c All letters are short so raise a bit.
+c
+ lbot1 = lbot1+1
+ else if (idno .ge. 13) then
+ lbot1 = lbot1+2
+ end if
+c
+c Convert so reference is bottom line
+c
+ lbot1 = lbot1-ncm+4
+ if ((fontslur.and.idno.eq.13) .or.
+ * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then
+c
+c Hairpin start. Save level and user-tweak before applying user tweak.
+c
+ levdsav(ivx) = lbot1
+ levhssav(ivx) = 0
+ if (btest(idynd,16)) levhssav(ivx) = -64+igetbits(idynd,7,17)
+ else if ((fontslur.and.idno.ge.14) .or. idno.eq.15) then
+c
+c Hairpin end; Compare level with saved start level before user-tweaks
+c
+ lbot1 = min(lbot1,levdsav(ivx))
+c
+c Save pre-tweak level
+c
+ lpretweak = lbot1
+ end if
+c
+c Check for user-defined vertical tweak
+c
+ if (btest(idynd,16)) lbot1 = lbot1-64+igetbits(idynd,7,17)
+c
+c Now horizontal stuff
+c
+ hoff = hoffsd
+c
+c Some special horizontal tweaks
+c
+ if (upstem .and. idno.gt.0 .and.
+ * (idno.le.4 .or. idno.eq.8 .or. idno.eq.9)) hoff = hoff+.4
+c
+c User-defined tweaks
+c
+ if (btest(idynd2,0))
+ * hoff = hoff+(igetbits(idynd2,9,1)-256)*.1
+ if (numdyn .gt. 1) then
+c
+c Horizontal-interaction-based tweaks.
+c
+c Cases:
+c numdyn type1 type2 type3 data used
+c 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12)
+c 2 hrpnend wrd-grp - ivowg,hoh2
+c 2 hrpnend hrpnstrt - hoh2h1(1...2)
+c 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1
+c
+ if (idno.gt.0 .and. idno.le.12) then
+c
+c Word-group, may need vertical tweak to line up.
+c
+ lbot1 = lbot1+ivowg(idno)
+c
+c Protecting against hp start-stop on same note
+c
+ else if (((fontslur.and.idno.ge.14).or.idno.eq.15)
+ * .and. icntdyn.lt.numdyn) then
+c
+c Hairpin ending, check next type
+c
+ if ((fontslur .and.
+ * igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13)
+ * .or. (.not.fontslur .and.
+ * ((igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13)
+ * .or.
+ * (igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.14))))
+ * then
+c
+c Hairpin end then hairpin start, no words, (remember dealing with end now)
+c
+ hoff = hoff+hoh2h1(1)
+ else
+c
+c Hairpin end then word-group, need idno for w-g to set hp offset
+c
+ hoff = hoff +
+ * hoh2(igetbits(idyndat(idynn(icntdyn+1)),4,12))
+ end if
+c
+c Protecting against hp start-stop on same note
+c
+ else if (icntdyn.gt.1 .and. idno.gt.0 .and.
+ * ((fontslur.and.idno.lt.14).or.
+ * (.not.fontslur.and.idno.lt.15))) then
+c
+c Hairpin start, check prior type
+c
+ if ((fontslur.and.
+ * igetbits(idyndat(idynn(icntdyn-1)),4,12).ge.14)
+ * .or.
+ * (.not.fontslur.and.
+ * igetbits(idyndat(idynn(icntdyn-1)),4,12).eq.15))
+ * then
+c
+c Hairpin end then hairpin start, (remember dealing with start now)
+c
+ hoff = hoff+hoh2h1(2)
+ else
+c
+c Hairpin start after word-group, need idno for w-g to set hp offset
+c
+ hoff = hoff+
+ * hoh1(igetbits(idyndat(idynn(icntdyn-1)),4,12))
+ end if
+ end if
+ end if
+c
+c End of if-block for 2- or 3-way interactions.
+c
+ if ((.not.fontslur) .and. idno.ge.13)
+c
+c Slur font and hairpin. Add hoff, and change from \interneote to \qn at width
+c
+ * hoff = (hoff+.5)*6./2.5
+c
+c Position corrections all done now. Put in the level.
+c
+ if ((fontslur.and.idno.eq.13) .or.
+ * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then
+c
+c Hairpin start.
+c
+ if (.not.fontslur) then
+c
+c Postscript hairpin start...inset placeholder for start level.
+
+ notexq = notexq(1:lnote)//'{ }'
+ lnote = lnote+5
+ end if
+ else
+c
+c Insert actual level in all cases except hairpin start
+c Create string with level in it
+c
+ if (lbot1 .gt. 9) then
+ numpq = '{'
+ write(numpq(2:3),'(i2)')lbot1
+ numpq = numpq(1:3)//'}'
+ lnumpq = 4
+ else if (lbot1 .gt. -1) then
+ numpq = char(48+lbot1)
+ lnumpq = 1
+ else if (lbot1 .gt. -10) then
+ numpq = '{'
+ write(numpq(2:3),'(i2)')lbot1
+ numpq = numpq(1:3)//'}'
+ lnumpq = 4
+ else
+ numpq = '{'
+ write(numpq(2:4),'(i3)')lbot1
+ numpq = numpq(1:4)//'}'
+ lnumpq = 5
+ end if
+c
+c Level has now been computed and stored in numpq
+c Append the level
+c
+ notexq = notexq(1:lnote)//numpq(1:lnumpq)
+ lnote = lnote+lnumpq
+ end if
+ if (abs(hoff) .lt. .001) then
+c
+c No horiz offset
+c
+ notexq = notexq(1:lnote)//'0'
+ lnote = lnote+1
+ else
+c
+c Horizontal tweak
+c
+ lform = lfmt1(hoff)
+ notexq = notexq(1:lnote)//'{'
+ lnote = lnote+1
+ write(notexq(lnote+1:lnote+lform),
+ * '(f'//chax(48+lform)//'.1)')hoff
+ lnote = lnote+lform
+ notexq = notexq(1:lnote)//'}'
+ lnote = lnote+1
+ end if
+ if (idno .eq. 0) then
+c
+c text-dynamic. Find the string and append it
+c
+ do 4 jtxtdyn = jtxtdyn1 , ntxtdyn
+c ivxip = ivx+16*ip
+ ivxip = ivx+32*ip
+ if (ivxip .eq. ivxiptxt(jtxtdyn)) go to 5
+4 continue
+ call printl('Abnormal stop in putdyn')
+ call stop1()
+5 continue
+ ltxtdyn = lenstr(txtdynq(jtxtdyn),128)
+c
+c Font size based on musicsize
+c
+c if (musize .eq. 20) then
+c notexq = notexq(1:lnote)//'{'//char(92)//'medtype'
+c * //char(92)//'it '
+c lnote = lnote+13
+c else if (musize .eq. 16) then
+c notexq = notexq(1:lnote)//'{'//char(92)//'normtype'
+c * //char(92)//'it '
+c lnote = lnote+14
+c else if (musize .eq. 24) then
+c notexq = notexq(1:lnote)//'{'//char(92)//'bigtype'
+c * //char(92)//'it '
+c lnote = lnote+13
+c else if (musize .eq. 29) then
+c notexq = notexq(1:lnote)//'{'//char(92)//'Bigtype'
+c * //char(92)//'it '
+c lnote = lnote+13
+c end if
+c
+c Do this to insert 1st 2 args of \txtdyn, allow 3rd to be longer (on next line)
+c
+ call addstr(notexq(1:lnote),lnote,soutq,lsout)
+ if (musize .eq. 20) then
+ notexq = '{'//char(92)//'medtype'//char(92)//'it '
+ lnote = 13
+ else if (musize .eq. 16) then
+ notexq = '{'//char(92)//'normtype'//char(92)//'it '
+ lnote = 14
+ else if (musize .eq. 24) then
+ notexq = '{'//char(92)//'bigtype'//char(92)//'it '
+ lnote = 13
+ else if (musize .eq. 29) then
+ notexq = '{'//char(92)//'Bigtype'//char(92)//'it '
+ lnote = 13
+ end if
+c
+ notexq = notexq(1:lnote)//txtdynq(jtxtdyn)(1:ltxtdyn)//'}'
+ lnote = lnote+ltxtdyn+1
+c
+c Reset jtxtdyn1 just in case >1 txtdyn on same note.
+c
+ jtxtdyn1 = jtxtdyn+1
+ else if (idno .le. 12) then
+c
+c Letter-group dynamic. Append the letter-group command
+c
+ id = 4*idno
+ dynstrq = dyntablq(id-3:id)
+ id = lenstr(dynstrq,4)
+ notexq = notexq(1:lnote)//chax(92)//dynstrq(1:id)
+ lnote = lnote+1+id
+ end if
+ call addstr(notexq(1:lnote),lnote,soutq,lsout)
+ if ((.not.fontslur).and.idno.eq.15) then
+c
+c PS slurs on, hairpin is ending. Go back and set height at beginning.
+c Add user-defined tweak to default level
+c
+ lbot1 = lpretweak+levhssav(ivx)
+ if (lbot1 .gt. 9) then
+ numpq = '{'
+ write(numpq(2:3),'(i2)')lbot1
+ numpq = numpq(1:3)//'}'
+ lnumpq = 4
+ else if (lbot1 .gt. -1) then
+ numpq = char(48+lbot1)
+ lnumpq = 1
+ else if (lbot1 .gt. -10) then
+ numpq = '{'
+ write(numpq(2:3),'(i2)')lbot1
+ numpq = numpq(1:3)//'}'
+ lnumpq = 4
+ else
+ numpq = '{'
+ write(numpq(2:4),'(i3)')lbot1
+ numpq = numpq(1:4)//'}'
+ lnumpq = 5
+ end if
+c
+c Construct string to search backwards for placeholder
+c
+ if (idh .le. 9) then
+ tempq = 'cresc'//char(48+idh)//'{ }'
+ ltemp = 11
+ else if (idh .le. 19) then
+ tempq = 'cresc'//'{1'//char(38+idh)//'}{ }'
+ ltemp = 14
+ else
+ tempq = 'cresc'//'{2'//char(28+idh)//'}{ }'
+ ltemp = 14
+ end if
+ write(11,'(a)')soutq(1:lsout)//'%'
+ lsout = 0
+ call backfill(11,tempq,ltemp,
+ * tempq(1:ltemp-5)//numpq(1:lnumpq),ltemp-5+lnumpq)
+ end if
+3 continue
+c
+c Shrink arrays, decrease ndyn 111109
+c
+ do 6 icntdyn = numdyn, 1 , -1
+ do 7 jdyn = idynn(icntdyn) , ndyn-1
+ idyndat(jdyn) = idyndat(jdyn+1)
+ idynda2(jdyn) = idynda2(jdyn+1)
+7 continue
+ ndyn = ndyn-1
+6 continue
+ end
+ subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,nacc,ig,ipl,
+ * farend,
+ * beamon,nolev,ncmidx,islur,nvmx,nv,ibmcnt,tnote,ulq,instno)
+c
+c ip will be one LESS than current note, for way-after's before bar-end,
+c It is only used to find ig.
+c ig is returned to makeabar in case there's a slur that needs to be ended
+c
+ parameter (nm=24)
+ logical beamon,stemup
+ common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
+ * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
+ * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
+ * graspace(37),
+ * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
+ * naccg(74),voltxtq(6),litq(83)
+ common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
+ * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
+ * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
+ * rtshfac
+ common /comask/ bar1syst,fixednew,scaldold,
+ * wheadpt,fbar,poenom
+ common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
+ * ,WrotePsslurDefaults,SlurCurve
+ common /comoct/ noctup
+ logical upg,slurg,slashg,bar1syst,upslur,btest,isgaft,iswaft,
+ * normsp,farend,fontslur,WrotePsslurDefaults
+ real*4 ptgr(37)
+ character*80 soutq
+ character*128 litq
+ character*79 notexq
+ character*20 voltxtq
+ character*10 figq
+ character*8 noteq,noteqGA
+ character*3 acsymq
+ character*1 sq,chax,udqq,ulq(nm,9)
+ common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
+ * fullsize(nm),ivxfig2,ivvfig(2,74)
+ sq = chax(92)
+ isgaft = btest(ipl,29)
+ iswaft = btest(ipl,31)
+ normsp = .not. isgaft
+c
+c Find ig.
+c
+ do 120 ig = 1 , ngrace
+ if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 121
+120 continue
+ print*,'Problem finding grace index in dograce'
+ stop
+121 continue
+ ngs = ngstrt(ig)
+ mg = multg(ig)
+c wheadpt1 = wheadpt*fullsize(ivx)
+ wheadpt1 = wheadpt*fullsize(instno)
+c
+c For way-after-graces at end of bar, must set the octave.
+c
+ if (farend) then
+ noctup = 0
+ if (ncm .eq.23) noctup = -2
+ end if
+ if (slurg(ig) .and. .not.iswaft .and..not.isgaft) then
+ if (listslur .eq. 16777215) then
+ print*
+ print*,'You defined the twentyfifth slur, one too many!'
+ write(15,'(/,a)')
+ * 'You defined the twentyfifth slur, one too many!'
+ call stop1()
+ end if
+c
+c Slur on fore-grace. Get index of next slur not in use, from 23 down.
+c
+ ndxslur = log2(16777215-listslur)
+
+ end if
+ if (nng(ig) .eq. 1) then
+c
+c Single grace.
+c
+ if (normsp) then
+c
+c Anything but GA
+c
+ call addstr(sq//'shlft',6,soutq,lsout)
+ niptgr = nint(ptgr(ig))
+c
+c Empirical tweak for postscript.
+c
+C if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3)
+c++
+ if (niptgr .lt. 10) then
+ call addstr(chax(48+niptgr)//'{',2,soutq,lsout)
+ else if (niptgr .lt. 100) then
+ write(notexq(1:2),'(i2)')niptgr
+ call addstr('{'//notexq(1:2)//'}{',5,soutq,lsout)
+ else
+ print*,
+ * 'Call Dr. Don if you really want grace note group > 99 pt'
+ stop
+ end if
+ else
+ call addstr(sq//'gaft{1.5}{',11,soutq,lsout)
+c
+c GA. Compute aftshft, for later use.
+c
+ aftshft = grafac
+ if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+agc1fac
+ aftshft = aftshft*wheadpt
+ end if
+ if (slurg(ig) .and. .not.isgaft .and..not.iswaft) then
+c
+c Start slur on pre-grace. No accounting needed since will be ended very soon.
+c
+ call notefq(noteq,lnoten,nolevg(ngs),ncm)
+ if (fontslur) then
+ if (upg(ig)) then
+ call addstr(sq//'islurd',7,soutq,lsout)
+ else
+ call addstr(sq//'isluru',7,soutq,lsout)
+ end if
+ else
+c
+c Start Postscript slur.
+c
+ if (upg(ig)) then
+ call addstr(sq//'isd',4,soutq,lsout)
+ else
+ call addstr(sq//'isu',4,soutq,lsout)
+ end if
+ end if
+c
+c Print slur number, 23-ndxslur
+c
+ lnote = 0
+ if (23-ndxslur .lt. 10) then
+c notexq = notexq(1:lnote)//chax(59-ndxslur)
+ notexq = chax(71-ndxslur)
+ lnote = 1
+ else if (23-ndxslur .lt. 20) then
+c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
+ notexq = '{1'//chax(61-ndxslur)//'}'
+ lnote = 4
+ else
+ notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
+ lnote = 4
+ end if
+ call addstr(notexq(1:lnote)//noteq(1:lnoten),
+ * lnote+lnoten,soutq,lsout)
+ if (.not.fontslur) then
+c
+c Horizontal tweaks for postscript slur on single grace
+c
+ stemup = .true.
+ if (upg(ig)) then
+c
+c Check for up-grace + down stem. Get stem direction
+c
+ if (.not.beamon) then
+c
+c Separate note. Get stem direction.
+c
+ stemup = udqq(nolev,ncmidx,
+ * islur,nvmx,ivx,nv) .eq. 'u'
+ else
+c
+c In a beam
+c
+ stemup = ulq(ivx,ibmcnt) .eq. 'u'
+ end if
+c
+c Stop the shift if whole note
+c
+ stemup = stemup .or. tnote.gt.63
+ end if
+ if (stemup) then
+ call addstr('{-.3}',5,soutq,lsout)
+ else
+ call addstr('{-.8}',5,soutq,lsout)
+ end if
+ end if
+ end if
+ if (naccg(ngs) .gt. 0) then
+ call notefq(noteq,lnoten,nolevg(ngs),ncm)
+c
+c Save for checking octave shifts in GA
+c
+ if (isgaft) then
+ lnotenGA = lnoten
+ noteqGA = noteq
+ end if
+c
+ if (lnoten .eq. 1) call addblank(noteq,lnoten)
+ call accsym(naccg(ngs),acsymq,lacc)
+ call addstr(sq//'big'//acsymq(1:lacc)//
+ * noteq(1:lnoten),4+lacc+lnoten,soutq,lsout)
+ end if
+ if (slashg(ig)) then
+ notexq = sq//'grc'
+ lnote = 4
+ else if (mg .eq. 0) then
+ notexq = sq//'zq'
+ lnote = 3
+ else
+ notexq = sq//'zc'
+ do 61 i = 2 , mg
+ notexq = notexq(1:i+1)//'c'
+61 continue
+ lnote = mg+2
+ end if
+ if (upg(ig)) then
+ notexq = notexq(1:lnote)//'u'
+ else
+ notexq = notexq(1:lnote)//'l'
+ end if
+ call addstr(notexq,lnote+1,soutq,lsout)
+ call notefq(noteq,lnoten,nolevg(ngs),ncm)
+c
+ if (isgaft .and. naccg(ngs).eq.0) then
+ lnotenGA = lnoten
+ noteqGA = noteq
+ end if
+c
+ if (lnoten .eq. 1) call addblank(noteq,lnoten)
+ call addstr(noteq,lnoten,soutq,lsout)
+ if (slashg(ig)) call addstr(sq//'off{-'//sq//
+ * 'noteskip}',16,soutq,lsout)
+c
+c Above code needed since slashg causes spacing
+c
+ if (slurg(ig) .and. (iswaft.or.isgaft)) then
+c
+c Terminate slur on single after-grace
+c
+ ndxslur = igetbits(ipl,5,23)
+ call notefq(noteq,lnoten,nolevg(ngs),ncm)
+ call addstr(sq//'tslur',6,soutq,lsout)
+c
+c Print 24-ndxslur
+c
+c if (11-ndxslur .lt. 10) then
+ if (23-ndxslur .lt. 10) then
+c call addstr(chax(59-ndxslur)//noteq(1:lnoten),
+ call addstr(chax(71-ndxslur)//noteq(1:lnoten),
+ * 1+lnoten,soutq,lsout)
+ else if (23-ndxslur .lt. 20) then
+ call addstr('{2'//chax(61-ndxslur)//'}'//noteq(1:lnoten),
+ * 4+lnoten,soutq,lsout)
+ else
+c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten),
+ call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten),
+ * 4+lnoten,soutq,lsout)
+ end if
+ slurg(ig) = .false.
+ listslur = ibclr(listslur,ndxslur)
+ end if
+ call addstr('}',1,soutq,lsout)
+c
+c+++ Try to fix loss of octave with single gaft
+c
+ if (isgaft) then
+ itrans = 0
+ do 1 i = 1 , lnotenGA
+ if (noteqGA(i:i) .eq. chax(39)) then
+ itrans = itrans+7
+ else if (noteqGA(i:i) .eq. chax(96)) then
+ itrans = itrans-7
+ end if
+1 continue
+ if (itrans. eq. -14) then
+ call addstr(sq//'advance'//sq//'transpose-14',21,
+ * soutq,lsout)
+ else if (itrans .eq. -7) then
+ call addstr(sq//'advance'//sq//'transpose-7',20,
+ * soutq,lsout)
+ else if (itrans .eq. 7) then
+ call addstr(sq//'advance'//sq//'transpose7',19,
+ * soutq,lsout)
+ else if (itrans .eq. 14) then
+ call addstr(sq//'advance'//sq//'transpose14',20,
+ * soutq,lsout)
+ end if
+ end if
+ else
+c
+c Multiple grace. Put in literally. Compute beam stuff
+c
+ sumx = 0.
+ sumy = 0.
+ sumxy = 0.
+ sumxx = 0.
+ sumyy = 0.
+ x = 0.
+ do 118 ing = ngs , ngs+nng(ig)-1
+ if (ing.gt.ngs .and. naccg(ing).gt.0) x = x+acgfac
+ y = nolevg(ing)
+ sumx = sumx + x
+ sumy = sumy + y
+ sumxy = sumxy + x*y
+ sumxx = sumxx + x*x
+ sumyy = sumyy + y*y
+ x = x+emgfac
+118 continue
+ delta = nng(ig)*sumxx-sumx*sumx
+ em = (nng(ig)*sumxy-sumx*sumy)/delta
+ islope = nint(0.5*em*gslfac)
+ if (iabs(islope) .gt. 9) islope = isign(9,islope)
+ beta = (sumy-islope/gslfac*sumx)/nng(ig)
+ nolev1 = nint(beta)
+c
+c Back up
+c
+ notexq = sq//'settiny'//sq//'off{'
+ if (normsp) then
+ write(notexq(14:18),'(a1,f4.1)')'-',ptgr(ig)
+ call addstr(notexq(1:18)//'pt}',21,soutq,lsout)
+ finalshift = ptgr(ig)
+ else
+ aftshft = wheadpt*1.33
+ if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+wheadpt*0.5
+ write(notexq(14:17),'(f4.1)')aftshft
+ call addstr(notexq(1:17)//'pt}'//sq//'bsk',24,soutq,lsout)
+ end if
+c
+c Start the beam
+c
+ notexq = sq//'ib'
+ do 119 ing = 2 , mg
+ notexq = notexq(1:ing+1)//'b'
+119 continue
+ if (upg(ig)) then
+ notexq = notexq(1:mg+2)//'u'
+ else
+ notexq = notexq(1:mg+2)//'l'
+ end if
+ notexq = notexq(1:mg+3)//'0'
+c
+c Get starting note for beam
+c
+ call notefq(noteq,lnoten,nolev1,ncm)
+ call addstr(notexq(1:mg+4)//noteq(1:lnoten),
+ * mg+4+lnoten,soutq,lsout)
+c
+c Put in the slope
+c
+ if (islope .ge. 0) then
+ call addstr(chax(48+islope),1,soutq,lsout)
+ else
+ call addstr('{-'//chax(48-islope)//'}',4,soutq,lsout)
+ end if
+c
+c Start a slur on multiple fore-grace
+c
+ if (slurg(ig) .and. .not.isgaft .and. .not.iswaft) then
+ call notefq(noteq,lnoten,nolevg(ngs),ncm)
+ if (fontslur) then
+ if (upg(ig)) then
+ call addstr(sq//'islurd',7,soutq,lsout)
+ else
+ call addstr(sq//'isluru',7,soutq,lsout)
+ end if
+ else
+c
+c Need a tweak for postscript slur
+c
+ if (upg(ig)) then
+ call addstr(sq//'isd',4,soutq,lsout)
+ else
+ call addstr(sq//'isu',4,soutq,lsout)
+ end if
+ end if
+c
+c Print 23-ndxslur
+c
+ if (23-ndxslur .lt. 10) then
+ call addstr(chax(71-ndxslur)//noteq(1:lnoten),1+lnoten,
+ * soutq,lsout)
+ else if (23-ndxslur .lt. 2) then
+ call addstr('{1'//chax(61-ndxslur)//'}'//noteq(1:lnoten),
+ * 4+lnoten,soutq,lsout)
+ else
+ call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten),
+ * 4+lnoten,soutq,lsout)
+ end if
+c
+c Put in tweak for postscript slur
+c
+ if (.not.fontslur) call addstr('{-.3}',5,soutq,lsout)
+ end if
+c
+c Put in first note. Call notefq again in case octave changed
+c
+ call notefq(noteq,lnoten,nolevg(ngs),ncm)
+ if (naccg(ngs) .eq. 0) then
+ notexq = sq//'zqb0'//noteq(1:lnoten)
+ lnote = 5+lnoten
+ else
+ if (lnoten .eq. 1) call addblank(noteq,lnoten)
+ call accsym(naccg(ngs),acsymq,lacc)
+ notexq = sq//'big'//acsymq(1:lacc)//noteq(1:lnoten)
+ lnote = 4+lacc+lnoten
+ call notefq(noteq,lnoten,nolevg(ngs),ncm)
+ notexq =notexq(1:lnote)//sq//'zqb0'//noteq(1:lnoten)
+ lnote = lnote+5+lnoten
+ end if
+ call addstr(notexq,lnote,soutq,lsout)
+ do 127 ing = ngs+1 , ngs+nng(ig)-1
+c
+c Skip
+c
+ ptoff = wheadpt1*emgfac
+ if (naccg(ing).gt.0) ptoff = ptoff+wheadpt1*acgfac
+ if (isgaft .and. .not.iswaft) aftshft = aftshft+ptoff
+ notexq = sq//'off{'
+ write(notexq(6:8),'(f3.1)')ptoff
+ if (normsp) finalshift = finalshift-ptoff
+ call addstr(notexq(1:8)//'pt}',11,soutq,lsout)
+ if (ing .eq. ngs+nng(ig)-1) then
+c
+c Terminate beam if needed
+c
+ if (upg(ig)) then
+ call addstr(sq//'tbu0',5,soutq,lsout)
+ else
+ call addstr(sq//'tbl0',5,soutq,lsout)
+ end if
+c
+c Terminate after slur if needed
+c
+ if ((isgaft.or.iswaft) .and. slurg(ig)) then
+c if (iswaft) ndxslur = igetbits(ipl,4,23)
+ if (iswaft) ndxslur = igetbits(ipl,5,23)
+ call notefq(noteq,lnoten,nolevg(ing),ncm)
+ call addstr(sq//'tslur',6,soutq,lsout)
+c
+c Print 11-ndxslur
+cc Print 23-ndxslur
+c
+ if (23-ndxslur .lt. 10) then
+ call addstr(chax(71-ndxslur)//noteq(1:lnoten),
+ * 1+lnoten,soutq,lsout)
+ else if (23-ndxslur .lt. 20) then
+ call addstr('{2'//chax(61-ndxslur)//'}'
+ * //noteq(1:lnoten),4+lnoten,soutq,lsout)
+ else
+ call addstr('{1'//chax(51-ndxslur)//'}'
+ * //noteq(1:lnoten),4+lnoten,soutq,lsout)
+ end if
+c
+c Stop slur terminator after exit from this subroutine
+c
+ listslur = ibclr(listslur,ndxslur)
+ slurg(ig) = .false.
+ end if
+ end if
+c
+c Accidental if needed
+c
+ if (naccg(ing).gt.0) then
+ call notefq(noteq,lnoten,nolevg(ing),ncm)
+ if (lnoten .eq. 1) call addblank(noteq,lnoten)
+ call accsym(naccg(ing),acsymq,lacc)
+ call addstr(sq//'big'//acsymq(1:lacc)
+ * //noteq(1:lnoten),4+lacc+lnoten,soutq,lsout)
+ end if
+c
+c Put in the (beamed) grace note
+c
+ call notefq(noteq,lnoten,nolevg(ing),ncm)
+ call addstr(sq//'zqb0'//noteq(1:lnoten),5+lnoten,
+ * soutq,lsout)
+127 continue
+c
+c Terminate the grace
+c
+c notexq = sq//'normalnotesize'//sq//'off{'
+c lnote = 20
+c notexq = '}'//sq//'off{'
+c lnote = 6
+ notexq = sq//'off{'
+ lnote = 5
+ ptoff = wheadpt*emgfac
+ if (iand(nacc,3).gt.0 .and. .not.btest(nacc,17))
+ * ptoff = ptoff+wheadpt*accfac
+ if (isgaft .and. .not.iswaft) then
+ notexq = notexq(1:5)//'-'
+ lnote = 6
+ ptoff = aftshft
+ end if
+ if (normsp) ptoff = finalshift
+ if (ptoff .lt. 9.95) then
+ write(notexq(lnote+1:lnote+3),'(f3.1)')ptoff
+ lnote = lnote+3
+ else if (ptoff .lt. 99.95) then
+ write(notexq(lnote+1:lnote+4),'(f4.1)')ptoff
+ lnote = lnote+4
+ else
+ write(notexq(lnote+1:lnote+5),'(f5.1)')ptoff
+ lnote = lnote+5
+ end if
+ call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout)
+ if (isgaft.and..not.iswaft) call addstr(sq//'sk',3,soutq,lsout)
+ call addstr(sq//'resetsize',10,soutq,lsout)
+ end if
+ return
+ end
+ subroutine dopsslur(nolev,isdat1,isdat2,isdat3,isdat4,nsdat,ip,
+ * iv,kv,nv,beamon,ncm,soutq,lsout,ulq,islur,
+ * ipl,iornq,islhgt,tno,nacc)
+c
+c Called once per main note.
+c 12 May 2002 Create this subroutine to isolate postscript slurs/ties.
+c Always set \Nosluradjust\Notieadjust
+c
+ parameter (nm=24,mv=24576)
+ integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202)
+ common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
+ * ,WrotePsslurDefaults,SlurCurve
+ common /commvl/ nvmx(nm),ivmx(nm,2),ivx
+ common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
+ * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
+ * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
+ common /comsln/ is1n1,is2n1,irzbnd,isnx
+ character*1 ulq,slurudq,udfq,udqq,chax
+ character*79 notexq
+ character*8 noteq
+ character*80 soutq
+ logical upslur,beamon,btest,stemup,iscrd,
+ * settie,fontslur,pstie,WrotePsslurDefaults
+ logical slmon,dbltie
+ common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
+ * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
+ * slmon(0:nm),dbltie
+ integer*2 mmidi,iinsiv
+ logical restpend,relacc,notmain,twoline,ismidi,crdacc
+ common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
+ * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
+ * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
+ * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
+ * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
+ * debugmidi
+ logical debugmidi
+ common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
+ * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
+ logical EarlyTransOn,LaterInstTrans
+c 130316
+ common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
+ * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
+c
+c Bits in isdat1:
+c 13-17 iv
+c 3-10 ip
+c 11 start/stop switch
+c 12 kv-1
+c 19-25 ichar(code$)
+c 26 force direction?
+
+c 27 forced dir'n = up if on, set in sslur; also
+c final direction, set in doslur when beam is started, used on term.
+c 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term.
+c 18 int(ndxslur/16), ditto. So this allows ndxslur>15.
+c 2 stem slur flag
+c 1 flag for "x" slur (voice-independent)
+c
+c Bits in isdat2
+c 0 Chord switch. Not set on main note.
+c 1-2 left/right notehead shift. Set only for chord note.
+c 3 tie positioning
+c 4 dotted flag
+c 6-11 voff1 1-63 => -31...+31
+c 12-18 hoff1 1-127 => -6.3...+6.3
+c 19-25 nolev
+c 26 \sluradjust (p+s)
+c 27 \nosluradjust (p-s)
+c 28 \tieadjust (p+t)
+c 29 \notieadjust (p-t)
+c
+c Bits in isdat3: Only used for slur endings
+c 0 set if midslur (at least one argument)
+c 1 set if curve (2 more args)
+c 2-7 32+first arg (height correction) (1st arg may be negative)
+c 8-10 second arg (initial slope)
+c 11-13 third arg (closing slope)
+c 14-21 tie level for use in LineBreakTies
+c 22-29 ncm for use in LineBreakTies
+c
+c Bits in isdat4 Only used for linebreak slurs
+c 0-5 Linebreak seg 1 voff 1-63 => -31...+31
+c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3
+c 16-21 Linebreak seg 2 voff 1-63 => -31...+31
+c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3
+c
+c In listslur bit ib is on if slur index ib is in use, ib=0-13.
+c ndxslur = slur index
+c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note,
+c s-slur is blank (idcode=32), t-slur is idcode=1.
+c ivoff is user-defined shift or shift due to . or _ , or chord adjustment.
+c Ivoff will be set for ./_ only if no user-defined shift is specified.
+c If highest note has upslur, save slur height in islhgt in case
+c ornament must be moved.
+c
+ islhgt = 0
+ if (beamon) then
+ stemup = ulq .eq. 'u'
+ else if (nvmx(iv) .eq. 2) then
+ if (.not.btest(islur,30)) then
+c
+c Single note, 2 lines of music, stem direction not forced
+c
+ stemup = ivx .gt. nv
+ else
+ stemup = btest(islur,17)
+ end if
+ else
+ stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u'
+ end if
+ iscrd = btest(ipl,10)
+ if (ismidi) then
+ settie = .false.
+ dbltie = .false.
+ end if
+ do 1 isdat = 1 , nsdat
+ isdata = isdat1(isdat)
+ if (iv .eq. igetbits(isdata,5,13) .and.
+ * ip .eq. igetbits(isdata,8,3) .and.
+c * kv .eq. igetbits(isdata,1,12)+1) then
+ * (kv .eq. igetbits(isdata,1,12)+1 .or.
+ * btest(isdata,1))) then
+c
+c Since iv and kv match, ivx will be correct
+c
+ idcode = igetbits(isdata,7,19)
+ ivoff = igetbits(isdat2(isdat),6,6)-32
+ ihoff = igetbits(isdat2(isdat),7,12)-64
+ iupdn = 0
+ slurudq = 'd'
+ nolevs = igetbits(isdat2(isdat),7,19)
+ pstie = btest(isdat2(isdat),3) .or. idcode.eq.1
+ if (btest(isdata,11)) then
+c
+c Turnon
+c Get slur direction
+c
+ if (btest(isdata,26)) then
+c
+c Force slur direction
+c
+ if (btest(isdata,27)) slurudq = 'u'
+ else if (nvmx(iv) .eq. 1) then
+c
+c Only one voice per line
+c
+ if (.not.beamon) then
+c
+c Separate note.
+c
+ slurudq = udfq(nolev,ncm)
+ else
+c
+c In a beam
+c
+ if (ulq .ne. 'u') slurudq = 'u'
+ end if
+ if (iscrd) then
+ if (nolevs .gt. ncm) then
+ slurudq = 'u'
+ else
+ slurudq = 'd'
+ end if
+ end if
+ else
+c
+c Two voices per line. Get default
+c
+ if (ivx .gt. nv) slurudq = 'u'
+c
+c Upper voice of the two, so up slur
+c
+ end if
+ if (btest(isdata,2)) then
+c
+c ADjust for stem slur. ASSUME this is the ONLY pos'n adjustment.
+c
+ if (stemup) then
+ slurudq = 'u'
+ ivoff = ivoff+4
+ else
+ slurudq = 'd'
+ ivoff = ivoff-4
+ end if
+ end if
+c
+c Set level for slur starting on rest
+c
+ if (nolevs.eq.0 .or. nolevs.gt.60) then
+ if (slurudq .eq. 'u') then
+ nolevs = ncm+2
+ else
+ nolevs = ncm-2
+ end if
+ end if
+c
+c Save up/down-ness for use at termination
+c
+ if (slurudq .eq. 'u') isdata = ibset(isdata,27)
+c
+c End of section for setting slur direction, still in "Turnon" if-block.
+c
+ if (btest(iornq,11).or.btest(iornq,12)) then
+c
+c Raise or lower slur by one unit provided . or _ is on same side as slur
+c
+ ivoffinc = 0
+ if ((stemup .and. slurudq.eq.'d') .or.
+ * (.not.stemup .and. slurudq.eq.'u')) then
+c
+c Must move the slur for _ or .
+c
+ if (stemup) then
+ ivoffinc = -1
+ else
+ ivoffinc = 1
+ end if
+ if (((stemup .and. nolev.ge.ncm-2) .or.
+ * (.not.stemup .and. nolev.le.ncm+2)) .and.
+ * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
+ ivoff = ivoff+ivoffinc
+ end if
+ end if
+ if (listslur .eq. 16777215) then
+ print*
+ print*,'You1 defined the twentyfifth slur, one too many!'
+ write(15,'(/,a)')
+ * 'You defined the twentyfifth slur, one too many!'
+ call stop1()
+ end if
+c
+c Get index of next slur not in use, starting from 12 down
+c
+ ndxslur = log2(16777215-listslur)
+c
+c Record slur index
+c
+ listslur = ibset(listslur,ndxslur)
+c
+c Save for use on termination
+c
+c call setbits(isdata,4,28,ndxslur)
+c 080531 Allow >16 slurs
+ call setbits(isdata,4,28,mod(ndxslur,16))
+ call setbits(isdata,1,18,ndxslur/16)
+c
+c Shift for stem?
+c
+ if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) then
+ if (.not.pstie) then
+ ihoff = ihoff+8
+ else
+ ihoff = ihoff+2
+ end if
+ end if
+ if (iscrd) then
+c
+c Additional horiz shifts for h-shifted noteheads?
+c
+ if (btest(isdat2(isdat),1)) then
+c
+c Slur start on left-shifted chord notehead. ASSUME downstem.
+c
+ if (nolevs.eq.minlev .and. slurudq.eq.'d') then
+ ihoff = ihoff-2
+ else
+ ihoff = ihoff-10
+ end if
+ else if (btest(isdat2(isdat),2)) then
+c
+c Right shifted chord notehead. ASSUME upstem.
+c
+ if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
+ ihoff = ihoff+2
+ else
+ ihoff = ihoff+10
+ end if
+ end if
+ end if
+ notexq = chax(92)
+ lnote = 1
+c
+c Check for local adjustment default changes
+c
+ if (btest(isdat2(isdat),26)) then
+ notexq = chax(92)//'sluradjust'//chax(92)
+ lnote = 12
+ else if (btest(isdat2(isdat),27)) then
+ notexq = chax(92)//'nosluradjust'//chax(92)
+ lnote = 14
+ else if (btest(isdat2(isdat),28)) then
+ notexq = chax(92)//'tieadjust'//chax(92)
+ lnote = 11
+ else if (btest(isdat2(isdat),29)) then
+ notexq = chax(92)//'notieadjust'//chax(92)
+ lnote = 13
+ end if
+ if (ihoff .eq. 0) then
+c
+c Write stuff for non-shifted start
+c
+ notexq = notexq(1:lnote)//'islur'//slurudq
+ lnote = lnote+6
+ else
+ notexq = notexq(1:lnote)//'is'//slurudq
+ lnote = lnote+3
+ end if
+c
+c Prepend postscript tie switch
+c
+ if (pstie) then
+ notexq = chax(92)//'tieforis'//slurudq//notexq(1:lnote)
+ lnote = lnote+10
+ end if
+ if (btest(isdat2(isdat),4)) then
+c
+c Dotted slur
+c
+c noteq = notexq
+c notexq = chax(92)//'dotted'//noteq
+ notexq = chax(92)//'dotted'//notexq(1:lnote)
+ lnote = lnote+7
+ end if
+c
+c Add slur index to string
+c Print 23-ndxslur
+c
+ if (23-ndxslur .lt. 10) then
+c
+c 5/25/08 Allow 24 slurs
+c
+ notexq = notexq(1:lnote)//chax(71-ndxslur)
+ lnote = lnote+1
+ else if (23-ndxslur .lt. 20) then
+ notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
+ lnote = lnote+4
+ else
+ notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
+ lnote = lnote+4
+ end if
+c
+c Add note name to string
+c
+ islhgt = nolevs+iupdn+ivoff
+ call notefq(noteq,lnoten,islhgt,ncm)
+ notexq = notexq(1:lnote)//noteq(1:lnoten)
+ lnote = lnote+lnoten
+c
+c Store height and staff mid level for use with LineBreakTies
+c
+ call setbits(isdat3(isdat),8,14,islhgt)
+ call setbits(isdat3(isdat),8,22,ncm)
+c
+c Save height (for ornament and barnobox interference) if topmost slur is up
+c
+ if (slurudq.eq.'u' .and.
+ * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
+ islhgt = nolevs+iupdn+ivoff
+c
+c Save height & idcode if top voice and slur start
+c
+ if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then
+ is1n1 = islhgt
+ is2n1 = idcode
+ end if
+ end if
+ if (ihoff .ne. 0.) then
+ shift = ihoff*0.1
+ notexq = notexq(1:lnote)//'{'
+ lnote = lnote+1
+ lform = lfmt1(shift)
+ write(notexq(lnote+1:lnote+lform),'(f'//
+ * chax(48+lform)//'.1)') shift
+ lnote = lnote+lform
+ notexq = notexq(1:lnote)//'}'
+ lnote = lnote+1
+ end if
+ call addstr(notexq,lnote,soutq,lsout)
+c
+c Zero out ip1 to avoid problems if slur goes to next input blk.
+c
+ call setbits(isdata,8,3,0)
+c
+c Set slur-on data for midi. Only treat null-index slurs and ps ties for now.
+c
+ if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then
+c levson(midchan(iv,kv)) = nolevs
+c 130316
+ levson(midchan(iv,kv)) = nolevs+miditran(instno(iv))
+ if (settie) dbltie = .true.
+c
+c Only way settie=T is if we just set a tie ending. So there's also a slur
+c start here, so set a flag telling addmidi not to zero out levson
+c
+ end if
+ else
+c
+c Slur is ending. Back thru list to find starting slur
+c
+ do 3 j = isdat-1 , 1 , -1
+ if (iv.eq.igetbits(isdat1(j),5,13) .and.
+c * kv.eq.igetbits(isdat1(j),1,12)+1) then
+ * (kv.eq.igetbits(isdat1(j),1,12)+1
+ * .or. btest(isdat1(j),1))) then
+ if (idcode .eq. igetbits(isdat1(j),7,19)) then
+ ndxslur = igetbits(isdat1(j),4,28)
+c
+c 080531 Allow >16 slurs
+c
+ * +16*igetbits(isdat1(j),1,18)
+ if (btest(isdat1(j),27)) slurudq = 'u'
+ go to 4
+ end if
+ end if
+3 continue
+ print*,'Bad place in doslur'
+ call stop1()
+4 continue
+c
+c Bugfix 070901 for slur ending on rest in 2-voice staff
+c
+ if (nolevs.le.2 .or. nolevs.gt.60) then
+c
+c Ending is on a rest, reset nolevs to default starting height
+c
+ nolevs = igetbits(isdat2(j),7,19)
+ end if
+ if (btest(isdat3(isdat),0) .or. btest(isdat3(j),0)) then
+c
+c Deal with \curve or \midslur. isdat is ending, j is start.
+c
+ if (btest(isdat3(isdat),0)) then
+ imid = igetbits(isdat3(isdat),6,2)-32
+ else
+ imid = igetbits(isdat3(j),6,2)-32
+ end if
+c
+c Postscript slurs, and \midslur adjustment is needed. Invoke macro
+c (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping:
+c Abs(imid) Postscript slur type
+c 1 f
+c 2-3 default
+c 4 h
+c 5 H
+c 6+ HH
+c
+ call addstr(chax(92)//'psforts'//
+ * chax(48+min(abs(imid),6)),9,soutq,lsout)
+ end if
+ if (btest(isdata,2)) then
+c
+c ADjust for stem slur.
+c
+ if (stemup) then
+ slurudq = 'u'
+ ivoff = ivoff+4
+ else
+ slurudq = 'd'
+ ivoff = ivoff-4
+ end if
+ end if
+c
+c Shift slur ending for stem on any note?
+c
+ if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) then
+ if (.not.pstie) then
+ ihoff = ihoff-8
+ else
+ ihoff = ihoff-3
+ end if
+ end if
+ if (iscrd) then
+c
+c Shift termination for shifted notehead?
+c
+ if (btest(isdat2(isdat),1)) then
+c
+c Left-shifted chord notehead. ASSUME downstem.
+c
+ if (nolevs.eq.minlev .and. slurudq.eq.'d') then
+ ihoff = ihoff-2
+ else
+ ihoff = ihoff-10
+ end if
+ else if (btest(isdat2(isdat),2)) then
+c
+c Right shifted chord notehead. ASSUME upstem.
+c
+ if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
+ ihoff = ihoff+2
+ else
+ ihoff = ihoff+10
+ end if
+ end if
+ end if
+ if (ihoff .eq. 0) then
+ notexq = chax(92)//'tslur'
+ lnote = 6
+ else
+c
+c Shift needed
+c
+ notexq = chax(92)//'ts'
+ lnote = 3
+ end if
+c
+c Switch to postscript tie
+c
+ if (pstie) then
+ notexq = chax(92)//'tieforts'//notexq(1:lnote)
+ lnote = lnote+9
+ end if
+c
+c Print 13-ndxslur
+c 5/25/08 Allow 14 slurs
+c
+ if (23-ndxslur .lt. 10) then
+ notexq = notexq(1:lnote)//chax(71-ndxslur)
+ lnote = lnote+1
+ else if (23-ndxslur .lt. 20) then
+ notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
+ lnote = lnote+4
+ else
+ notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
+ lnote = lnote+4
+ end if
+ if (btest(iornq,11).or.btest(iornq,12)) then
+c
+c Raise or lower slur by one unit provided . or _ is on same side as slur
+c
+ ivoffinc = 0
+ if ((stemup .and. slurudq.eq.'d') .or.
+ * (.not.stemup .and. slurudq.eq.'u')) then
+ if (stemup) then
+ ivoffinc = -1
+ else
+ ivoffinc = 1
+ end if
+ if (((stemup .and. nolev.ge.ncm-2) .or.
+ * (.not.stemup .and. nolev.le.ncm+2)) .and.
+ * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
+ end if
+ ivoff = ivoff+ivoffinc
+ end if
+ call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
+ if (slurudq.eq.'u' .and.
+ * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
+ islhgt = nolevs+iupdn+ivoff
+c
+c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno.
+c
+ if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then
+ if (idcode .eq. is2n1) is1n1=0
+ end if
+ end if
+ notexq = notexq(1:lnote)//noteq(1:lnoten)
+ lnote = lnote+lnoten
+ if (ihoff .ne. 0) then
+ shift = ihoff*0.1
+ notexq = notexq(1:lnote)//'{'
+ lnote = lnote+1
+ lform = lfmt1(shift)
+ write(notexq(lnote+1:lnote+lform),
+ * '(f'//chax(48+lform)//'.1)')shift
+ lnote = lnote+lform
+ notexq = notexq(1:lnote)//'}'
+ lnote = lnote+1
+ end if
+ call addstr(notexq,lnote,soutq,lsout)
+c
+c Clear the bit from list of slurs in use
+c
+ listslur = ibclr(listslur,ndxslur)
+c
+c Zero out the entire strings for start and stop
+c
+ isdata = 0
+ isdat2(isdat) = 0
+ isdat3(isdat) = 0
+ isdat4(isdat) = 0
+ isdat1(j) = 0
+ isdat2(j) = 0
+ isdat3(j) = 0
+ isdat4(j) = 0
+c
+c Set midi info for slur ending
+c
+ if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then
+ icm = midchan(iv,kv)
+ if (slmon(icm)) then
+ if (nolevs+miditran(instno(iv)).eq.levson(icm) .and.
+ * iand(7,nacc).eq.0) then
+c
+c There is a tie here. NB!!! assumed no accidental on 2nd member of tie.
+c
+ levsoff(icm) = nolevs+miditran(instno(iv))
+ settie = .true.
+ else
+ levsoff(icm) = 0
+ levson(icm) = 0
+ slmon(icm) = .false.
+ end if
+ end if
+ end if
+ end if
+ isdat1(isdat) = isdata
+ end if
+1 continue
+c
+c Clear and collapse the slur data list
+c
+ numdrop = 0
+ do 2 isdat = 1 , nsdat
+ if (isdat1(isdat) .eq. 0) then
+ numdrop = numdrop+1
+ else if (numdrop .gt. 0) then
+ isdat1(isdat-numdrop) = isdat1(isdat)
+ isdat2(isdat-numdrop) = isdat2(isdat)
+ isdat3(isdat-numdrop) = isdat3(isdat)
+ isdat4(isdat-numdrop) = isdat4(isdat)
+ isdat1(isdat) = 0
+ isdat2(isdat) = 0
+ isdat3(isdat) = 0
+ isdat4(isdat) = 0
+ end if
+2 continue
+ nsdat = nsdat-numdrop
+c call report(nsdat,isdat1,isdat2)
+ return
+ end
+ subroutine doslur(nolev,isdat1,isdat2,isdat3,nsdat,ip,iv,kv,nv,
+ * beamon,ncm,soutq,lsout,ulq,islur,ipl,iornq,islhgt,tno,nacc)
+c
+c Called once per main note. (5/26/02) for non-ps slurs only
+c
+ parameter (nm=24,mv=24576)
+ integer*4 isdat1(202),isdat2(202),isdat3(202)
+ common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
+ * ,WrotePsslurDefaults,SlurCurve
+ common /commvl/ nvmx(nm),ivmx(nm,2),ivx
+ common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
+ * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
+ * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
+ common /comsln/ is1n1,is2n1,irzbnd,isnx
+ character*1 ulq,slurudq,udfq,udqq,chax
+ character*79 notexq
+ character*8 noteq
+ character*80 soutq
+ logical upslur,beamon,btest,stemup,iscrd,sfound,tfound,tmove,
+ * settie,fontslur,WrotePsslurDefaults
+ logical slmon,dbltie
+ common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
+ * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
+ * slmon(0:nm),dbltie
+ integer*2 mmidi,iinsiv
+ logical restpend,relacc,notmain,twoline,ismidi,crdacc
+ common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
+ * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
+ * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
+ * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
+ * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
+ * debugmidi
+ logical debugmidi
+ common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
+ * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
+ logical EarlyTransOn,LaterInstTrans
+c 130316
+ common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
+ * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm)
+c
+c Bits in isdat1:
+c 13-17 iv
+c 3-10 ip
+c 11 start/stop switch
+c 12 kv-1
+c 19-25 ichar(code$)
+c 26 force direction?
+c 27 forced dir'n = up if on, set in sslur; also
+c final direction, set in doslur when beam is started, used on term.
+c 28-31 ndxslur, set in doslur when beam is started, used on term.
+c
+c Bits in isdat2
+c 0 Chord switch. Not set on main note.
+c 1-2 left/right notehead shift. Set only for chord note.
+c 3 tie positioning
+c 4 dotted flag
+c 6-11 voff1 1-63 => -31...+31
+c 12-18 hoff1 1-127 => -6.3...+6.3
+c 19-25 nolev
+c
+c Bits in isdat3: Only used for slur endings
+c 0 set if midslur (at least one argument)
+c 1 set if curve (2 more args)
+c 2-7 32+first arg (height correction) (1st arg may be negative)
+c 8-10 second arg (initial slope)
+c 11-13 third arg (closing slope)
+c
+c In listslur bit ib is on if slur index ib is in use, ib=0-23.
+c ndxslur = slur index
+c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note,
+c s-slur is blank (idcode=32), t-slur is idcode=1.
+c ivoff is user-defined shift or shift due to . or _ , or chord adjustment.
+c Ivoff will be set for ./_ only if no user-defined shift is specified.
+c If highest note has upslur, save slur height in islhgt in case
+c ornament must be moved.
+c
+ islhgt = 0
+ if (beamon) then
+ stemup = ulq .eq. 'u'
+ else if (nvmx(iv) .eq. 2) then
+ if (.not.btest(islur,30)) then
+c
+c Single note, 2 lines of music, stem direction not forced
+c
+ stemup = ivx .gt. nv
+ else
+ stemup = btest(islur,17)
+ end if
+ else
+ stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u'
+ end if
+ iscrd = btest(ipl,10)
+ if (btest(islur,1)) then
+c
+c 't'-slur (idcode=1) somewhere on this note. Find it, check height against
+c 's'-slur (idcode=32)
+c
+ sfound = .false.
+ tfound = .false.
+ tmove = .false.
+ do 5 isdat = 1 , nsdat
+ if (iv .eq. igetbits(isdat1(isdat),5,13) .and.
+ * ip .eq. igetbits(isdat1(isdat),8,3) .and.
+ * kv .eq. igetbits(isdat1(isdat),1,12)+1) then
+ if (.not.tfound) then
+ tfound = igetbits(isdat1(isdat),7,19).eq.1
+ if (tfound) then
+ nolevt = igetbits(isdat2(isdat),7,19)
+ isdatt = isdat
+ if (sfound) go to 6
+ end if
+ end if
+ if (.not.sfound) then
+ sfound = igetbits(isdat1(isdat),7,19).eq.32
+ if (sfound) then
+ nolevs = igetbits(isdat2(isdat),7,19)
+ isdats = isdat
+ if (tfound) go to 6
+ end if
+ end if
+ end if
+5 continue
+c
+c Will come thru here if there is a t with no s, so comment out the following
+c print*,'Did not find s+t-slurs in doslur'
+c
+6 continue
+ if (sfound .and. tfound)
+ * tmove = nolevs.eq.nolevt .and.
+c
+c Check if 2 starts or two stops
+c
+ * ((btest(isdat1(isdats),11).and.btest(isdat1(isdatt),11)) .or.
+ * (.not.btest(isdat1(isdats),11).and.
+ * .not.btest(isdat1(isdatt),11)) )
+c
+c This is a flag for later changing slur level, after we know slur dir'n.
+c
+ end if
+ if (ismidi) then
+ settie = .false.
+ dbltie = .false.
+ end if
+ do 1 isdat = 1 , nsdat
+ isdata = isdat1(isdat)
+ if (iv .eq. igetbits(isdata,5,13) .and.
+ * ip .eq. igetbits(isdata,8,3) .and.
+ * kv .eq. igetbits(isdata,1,12)+1) then
+c
+c Since iv and kv match, ivx will be correct
+c
+ idcode = igetbits(isdata,7,19)
+ ivoff = igetbits(isdat2(isdat),6,6)-32
+ ihoff = igetbits(isdat2(isdat),7,12)-64
+ iupdn = 0
+ slurudq = 'd'
+ nolevs = igetbits(isdat2(isdat),7,19)
+ if (btest(isdata,11)) then
+c
+c Turnon,
+c
+ if (nolevs.eq.0 .or. nolevs.gt.60) then
+c
+c Note was a rest, cannot start slur on rest.
+c
+ print*
+ call printl('Cannot start slur on a rest')
+ call stop1()
+ end if
+c
+c Get slur direction
+c
+ if (btest(isdata,26)) then
+c
+c Force slur direction
+c
+ if (btest(isdata,27)) slurudq = 'u'
+ else if (nvmx(iv) .eq. 1) then
+c
+c Only one voice per line
+c
+ if (.not.beamon) then
+c
+c Separate note.
+c
+ slurudq = udfq(nolev,ncm)
+ else
+c
+c In a beam
+c
+ if (ulq .ne. 'u') slurudq = 'u'
+ end if
+ if (iscrd) then
+ if (nolevs .gt. ncm) then
+ slurudq = 'u'
+ else
+ slurudq = 'd'
+ end if
+ end if
+ else
+c
+c Two voices per line. Get default
+c
+ if (ivx .gt. nv) slurudq = 'u'
+c
+c Upper voice of the two, so up slur
+c
+ end if
+c
+c Save up/down-ness for use at termination
+c
+ if (slurudq .eq. 'u') isdata = ibset(isdata,27)
+c
+c End of section for setting slur direction, still in "Turnon" if-block.
+c
+ if (idcode.eq.1 .and. tmove) then
+ iupdn = 1
+ if (slurudq .eq. 'd') iupdn = -1
+ end if
+ if (btest(iornq,11).or.btest(iornq,12)) then
+c
+c Raise or lower slur by one unit provided . or _ is on same side as slur
+c
+ ivoffinc = 0
+ if ((stemup .and. slurudq.eq.'d') .or.
+ * (.not.stemup .and. slurudq.eq.'u')) then
+c
+c Must move the slur for _ or .
+c
+ if (stemup) then
+ ivoffinc = -1
+ else
+ ivoffinc = 1
+ end if
+ if (((stemup .and. nolev.ge.ncm-2) .or.
+ * (.not.stemup .and. nolev.le.ncm+2)) .and.
+ * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
+ ivoff = ivoff+ivoffinc
+ end if
+ end if
+ if (listslur .eq. 16777215) then
+ print*
+ print*,'You1 defined the twenty-fifth slur, one too many!'
+ write(15,'(/,a)')
+ * 'You2 defined the twenty-fifth slur, one too many!'
+ call stop1()
+ end if
+c
+c Get index of next slur not in use, starting from ? down
+c
+ ndxslur = log2(16777215-listslur)
+c
+c Record slur index
+c
+ listslur = ibset(listslur,ndxslur)
+c
+c Save for use on termination
+c
+c call setbits(isdata,4,28,ndxslur)
+c 080531 Allow >16 slurs
+ call setbits(isdata,4,28,mod(ndxslur,16))
+ call setbits(isdata,1,18,ndxslur/16)
+c
+c Shift for stem?
+c
+ if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.)
+ * ihoff = ihoff+8
+ if (btest(isdat2(isdat),3)) then
+c
+c Tie spacing, (slur start)
+c
+ if (slurudq.eq.'d') then
+ ivoff = ivoff+1
+ ihoff = ihoff+8
+ else if (slurudq.eq.'u') then
+ ivoff = ivoff-1
+ if (.not.(stemup.and.tno.lt.63.)) ihoff = ihoff+8
+c
+c (already shifted if (stemup.and.tno.gt.63.) and slurudq='u')
+c
+ end if
+ end if
+ if (iscrd) then
+c
+c Additional horiz shifts for h-shifted noteheads?
+c
+ if (btest(isdat2(isdat),1)) then
+c
+c Slur start on left-shifted chord notehead. ASSUME downstem.
+c
+ if (nolevs.eq.minlev .and. slurudq.eq.'d') then
+ ihoff = ihoff-2
+ else
+ ihoff = ihoff-10
+ end if
+ else if (btest(isdat2(isdat),2)) then
+c
+c Right shifted chord notehead. ASSUME upstem.
+c
+ if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
+ ihoff = ihoff+2
+ else
+ ihoff = ihoff+10
+ end if
+ end if
+ end if
+ if (ihoff .eq. 0) then
+c
+c Write stuff for non-shifted start
+c
+ notexq = chax(92)//'islur'//slurudq
+ lnote = 7
+ else
+ notexq = chax(92)//'is'//slurudq
+ lnote = 4
+ end if
+ if (btest(isdat2(isdat),4)) then
+c
+c Dotted slur
+c
+ noteq(1:8) = notexq
+ notexq = chax(92)//'dotted'//noteq
+ lnote = lnote+7
+ end if
+c
+c Add slur index to string
+cc Print 11-ndxslur
+c Print 23-ndxslur
+c
+c if (11-ndxslur .lt. 10) then
+ if (23-ndxslur .lt. 10) then
+c
+c 5/25/08 Allow 24 slurs
+c
+c notexq = notexq(1:lnote)//chax(59-ndxslur)
+ notexq = notexq(1:lnote)//chax(71-ndxslur)
+ lnote = lnote+1
+ else if (23-ndxslur .lt. 20) then
+c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
+ notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
+ lnote = lnote+4
+ else
+ notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
+ lnote = lnote+4
+ end if
+c
+c Add note name to string
+c
+ call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
+ notexq = notexq(1:lnote)//noteq(1:lnoten)
+ lnote = lnote+lnoten
+c
+c Save height (for ornament and barnobox interference) if topmost slur is up
+c
+ if (slurudq.eq.'u' .and.
+ * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
+ islhgt = nolevs+iupdn+ivoff
+c
+c Save height & idcode if top voice and slur start
+c
+ if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then
+ is1n1 = islhgt
+ is2n1 = idcode
+ end if
+ end if
+ if (ihoff .ne. 0.) then
+ shift = ihoff*0.1
+ notexq = notexq(1:lnote)//'{'
+ lnote = lnote+1
+ lform = lfmt1(shift)
+ write(notexq(lnote+1:lnote+lform),'(f'//
+ * chax(48+lform)//'.1)') shift
+ lnote = lnote+lform
+ notexq = notexq(1:lnote)//'}'
+ lnote = lnote+1
+ end if
+ call addstr(notexq,lnote,soutq,lsout)
+c
+c Zero out ip1 to avoid problems if slur goes to next input blk.
+c
+ call setbits(isdata,8,3,0)
+c
+c Set slur-on data for midi. Only treat null-index slurs and ps ties for now.
+c
+ if (ismidi .and. idcode.eq.32) then
+ levson(midchan(iv,kv)) = nolevs+miditran(instno(iv))
+ if (settie) dbltie = .true.
+c
+c Only way settie=T is if we just set a tie ending. So there's also a slur
+c start here, so set a flag telling addmidi not to zero out levson
+c
+ end if
+ else
+c
+c Slur is ending. Back thru list to find starting slur
+c
+ do 3 j = isdat-1 , 1 , -1
+ if (iv.eq.igetbits(isdat1(j),5,13) .and.
+ * kv.eq.igetbits(isdat1(j),1,12)+1) then
+ if (idcode .eq. igetbits(isdat1(j),7,19)) then
+ ndxslur = igetbits(isdat1(j),4,28)
+c
+c 080531 Allow >16 slurs
+c
+ * +16*igetbits(isdat1(j),1,18)
+ if (btest(isdat1(j),27)) slurudq = 'u'
+ go to 4
+ end if
+ end if
+3 continue
+ print*,'Bad place in doslur'
+ call stop1()
+4 continue
+ if (nolevs.eq.0 .or. nolevs.gt.60) then
+c
+c Ending is on a rest, reset nolevs to default starting height
+c
+ nolevs = igetbits(isdat2(j),7,19)
+ end if
+ if (btest(isdat3(isdat),0)) then
+c
+c Deal with \curve or \midslur
+c
+ imid = igetbits(isdat3(isdat),6,2)-32
+c
+c Remember, only dealing with non-ps slurs
+c
+c Who knows where the following line came from. Removed it 6/30/02 to
+c restore behavior of non-ps slurs to old way
+c if (slurudq .eq. 'd') imid = -imid
+c 3/8/03 added the following
+c
+ if (slurudq .eq. 'd') imid = -abs(imid)
+c
+ if (btest(isdat3(isdat),1)) then
+ notexq = chax(92)//'curve'
+ lnote = 6
+ else
+ notexq = chax(92)//'midslur'
+ lnote = 8
+ end if
+ if (imid.lt.0 .or. imid.gt.9) then
+c
+c Need brackets
+c
+ notexq = notexq(1:lnote)//'{'
+ lnote = lnote+1
+ if (imid .lt. -9) then
+ write(notexq(lnote+1:lnote+3),'(i3)')imid
+ lnote = lnote+3
+ else if (imid.lt.0 .or. imid.gt.9) then
+ write(notexq(lnote+1:lnote+2),'(i2)')imid
+ lnote = lnote+2
+ else
+ write(notexq(lnote+1:lnote+1),'(i1)')imid
+ lnote = lnote+1
+ end if
+ notexq = notexq(1:lnote)//'}'
+ lnote = lnote+1
+ else
+c
+c 1=<imid=<9, no brackets
+c
+ notexq = notexq(1:lnote)//char(48+imid)
+ lnote = lnote+1
+ end if
+ if (btest(isdat3(isdat),1)) then
+c
+c \curve; 3 args
+c
+ notexq = notexq(1:lnote)
+ * //char(48+igetbits(isdat3(isdat),3,8))
+ notexq = notexq(1:lnote+1)
+ * //char(48+igetbits(isdat3(isdat),3,11))
+ lnote = lnote+2
+ end if
+ call addstr(notexq,lnote,soutq,lsout)
+ end if
+c
+c Shift slur ending for stem on any note?
+c
+ if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.)
+ * ihoff = ihoff-8
+ if (btest(isdat2(isdat),3)) then
+c
+c Shift ending for tie spacing
+c
+ if (slurudq .eq. 'u') then
+ ihoff = ihoff-8
+ ivoff = ivoff-1
+ else if (slurudq .eq. 'd') then
+ ivoff = ivoff+1
+ if (stemup.or. tno.gt.63.) ihoff = ihoff-8
+ end if
+ end if
+ if (iscrd) then
+c
+c Shift termination for shifted notehead?
+c
+ if (btest(isdat2(isdat),1)) then
+c
+c Left-shifted chord notehead. ASSUME downstem.
+c
+ if (nolevs.eq.minlev .and. slurudq.eq.'d') then
+ ihoff = ihoff-2
+ else
+ ihoff = ihoff-10
+ end if
+ else if (btest(isdat2(isdat),2)) then
+c
+c Right shifted chord notehead. ASSUME upstem.
+c
+ if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
+ ihoff = ihoff+2
+ else
+ ihoff = ihoff+10
+ end if
+ end if
+ end if
+ if (ihoff .eq. 0) then
+ notexq = chax(92)//'tslur'
+ lnote = 6
+ else
+c
+c Shift needed
+c
+ notexq = chax(92)//'ts'
+ lnote = 3
+ end if
+c
+c Print 23-ndxslur
+c 5/25/08 Allow 14 slurs (???????????)
+c
+ if (23-ndxslur .lt. 10) then
+ notexq = notexq(1:lnote)//chax(71-ndxslur)
+ lnote = lnote+1
+ else if (23-ndxslur .lt. 20) then
+ notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
+ lnote = lnote+4
+ else
+ notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
+ lnote = lnote+4
+ end if
+ if (btest(iornq,11).or.btest(iornq,12)) then
+c
+c Raise or lower slur by one unit provided . or _ is on same side as slur
+c
+ ivoffinc = 0
+ if ((stemup .and. slurudq.eq.'d') .or.
+ * (.not.stemup .and. slurudq.eq.'u')) then
+ if (stemup) then
+ ivoffinc = -1
+ else
+ ivoffinc = 1
+ end if
+ if (((stemup .and. nolev.ge.ncm-2) .or.
+ * (.not.stemup .and. nolev.le.ncm+2)) .and.
+ * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
+ end if
+ ivoff = ivoff+ivoffinc
+ end if
+ if (idcode.eq.1 .and. tmove) then
+c
+c t-slur height adjustment
+c
+ iupdn = 1
+ if (slurudq .eq. 'd') iupdn = -1
+ end if
+ call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
+ if (slurudq.eq.'u' .and.
+ * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
+ islhgt = nolevs+iupdn+ivoff
+c
+c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno.
+c
+ if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then
+ if (idcode .eq. is2n1) is1n1=0
+ end if
+ end if
+ notexq = notexq(1:lnote)//noteq(1:lnoten)
+ lnote = lnote+lnoten
+ if (ihoff .ne. 0) then
+ shift = ihoff*0.1
+ notexq = notexq(1:lnote)//'{'
+ lnote = lnote+1
+ lform = lfmt1(shift)
+ write(notexq(lnote+1:lnote+lform),
+ * '(f'//chax(48+lform)//'.1)')shift
+ lnote = lnote+lform
+ notexq = notexq(1:lnote)//'}'
+ lnote = lnote+1
+ end if
+ call addstr(notexq,lnote,soutq,lsout)
+c
+c Clear the bit from list of slurs in use
+c
+ listslur = ibclr(listslur,ndxslur)
+c
+c Zero out the entire strings for start and stop
+c
+ isdata = 0
+ isdat2(isdat) = 0
+ isdat1(j) = 0
+ isdat2(j) = 0
+ isdat3(isdat) = 0
+c
+c Set midi info for slur ending
+c
+ if (ismidi .and. idcode.eq.32) then
+ icm = midchan(iv,kv)
+ if (slmon(icm)) then
+ if (nolevs+miditran(instno(iv)).eq.levson(icm) .and.
+ * iand(7,nacc).eq.0) then
+c
+c There is a tie here. NB!!! assumed no accidental on 2nd member of tie.
+c
+ levsoff(icm) = nolevs+miditran(instno(iv))
+ settie = .true.
+ else
+ levsoff(icm) = 0
+ levson(icm) = 0
+ slmon(icm) = .false.
+ end if
+ end if
+ end if
+ end if
+ isdat1(isdat) = isdata
+ end if
+1 continue
+c
+c Clear and collapse the slur data list
+c
+ numdrop = 0
+ do 2 isdat = 1 , nsdat
+ if (isdat1(isdat) .eq. 0) then
+ numdrop = numdrop+1
+ else if (numdrop .gt. 0) then
+ isdat1(isdat-numdrop) = isdat1(isdat)
+ isdat2(isdat-numdrop) = isdat2(isdat)
+ isdat3(isdat-numdrop) = isdat3(isdat)
+ isdat1(isdat) = 0
+ isdat2(isdat) = 0
+ isdat3(isdat) = 0
+ end if
+2 continue
+ nsdat = nsdat-numdrop
+c call report(nsdat,isdat1,isdat2)
+ return
+ end
+ subroutine dotmov(updot,rtdot,soutq,lsout,iddot)
+c
+c iddot = 0 for single dot, 1 for double
+c
+ character*80 soutq,notexq
+ character*1 sq,chax
+ sq = chax(92)
+ lfmtup = lfmt1(updot)
+ lfmtrt = lfmt1(rtdot)
+ write(notexq,'(a37,f'//chax(48+lfmtup)//'.1,a2,f'//chax(48+lfmtrt)
+ * //'.1,a15)')
+ * sq//'makeatletter'//sq//'def'//sq//'C at Point#1#2{'//sq//
+ * 'PMXpt{',updot,'}{',rtdot,'}'//chax(48+iddot)//'}'//sq
+ * //'makeatother'
+c
+c Example of string just created:
+c \makeatletter\def\C at Point#1#2{\PMXpt{.5}{.5}}\makeatother\
+c
+ lnote = 54+lfmtup+lfmtrt
+ call addstr(notexq(1:lnote),lnote,soutq,lsout)
+ return
+ end
+ subroutine dotrill(iv,ip,iornq,noteq,lnoten,notexq,lnote)
+ common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
+ * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
+ * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
+ character*1 chax
+ character*8 noteq
+ character*79 notexq
+ logical tronly,btest
+ do 1 itr = 1 , ntrill
+ if (iv.eq.ivtrill(itr) .and. ip.eq.iptrill(itr)) go to 2
+1 continue
+ print*,'Problem in dotrill. Call Dr. Don'
+ stop
+2 continue
+ tronly = xnsktr(itr) .lt. 0.01
+ if (tronly) then
+ notexq = chax(92)//'zcharnote'
+ lnote = 10
+ else if (btest(iornq,7)) then
+ notexq = chax(92)//'Trille'
+ lnote = 7
+ else
+ notexq = chax(92)//'trille'
+ lnote = 7
+ end if
+ notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
+ lnote = lnote+lnoten+1
+c
+c Write trill duration to nearest tenth of a noteskip
+c
+ if (tronly) then
+ notexq = notexq(1:lnote)//chax(92)//'it tr}'
+ lnote = lnote+7
+ return
+ end if
+ if (xnsktr(itr) .lt. .95) then
+ nfmt = 2
+ else if (xnsktr(itr) .lt. 9.95) then
+ nfmt = 3
+ else
+ nfmt = 4
+ end if
+ write(notexq(lnote+1:lnote+nfmt),'(f'//chax(48+nfmt)//'.1)')
+ * xnsktr(itr)
+ lnote = lnote+nfmt
+ notexq = notexq(1:lnote)//'}'
+ lnote = lnote+1
+ return
+ end
+ subroutine endslur(stemup,upslur,nolev,iupdn,ndxslur,ivoff,ncm,
+ * soutq,lsout,fontslur)
+c
+c Only called to end slur started in dograce.
+c
+ logical shift,stemup,upslur,fontslur
+ character*80 soutq
+ character*79 notexq
+ character*8 noteq
+ character*1 chax
+ shift = .not.stemup .and. .not.upslur
+ if (.not.shift) then
+c
+c No shift needed
+c
+ notexq = chax(92)//'tslur'
+ lnote = 6
+ else
+c
+c Shift needed
+c
+ notexq = chax(92)//'ts'
+ lnote = 3
+ end if
+c if (ndxslur .lt. 10) then
+c notexq = notexq(1:lnote)//chax(48+ndxslur)
+c lnote = lnote+1
+c else
+c notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}'
+c lnote = lnote+4
+c end if
+c
+cc Print 11-ndxslur
+c Print 23-ndxslur
+c
+c if (11-ndxslur .lt. 10) then
+ if (23-ndxslur .lt. 10) then
+c notexq = notexq(1:lnote)//chax(59-ndxslur)
+ notexq = notexq(1:lnote)//chax(71-ndxslur)
+ lnote = lnote+1
+ else if (23-ndxslur .lt. 20) then
+c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
+ notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
+ lnote = lnote+4
+ else
+ notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
+ lnote = lnote+4
+ end if
+ call notefq(noteq,lnoten,nolev+iupdn+ivoff,ncm)
+ notexq = notexq(1:lnote)//noteq(1:lnoten)
+ lnote = lnote+lnoten
+ if (shift) then
+ if (fontslur) then
+ notexq = notexq(1:lnote)//'{-.6}'
+ else
+ notexq = notexq(1:lnote)//'{-.8}'
+ end if
+ lnote = lnote+5
+ end if
+ call addstr(notexq,lnote,soutq,lsout)
+ return
+ end
+ subroutine errmsg(lineq,iccount,ibarno,msgq)
+ parameter(nm=24)
+ common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
+ * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
+ logical lastchar,fbon,issegno,isheadr,isvolt
+ character*128 lineq
+ character*78 outq
+ character*(*) msgq
+ character*1 chax
+ common /truelinecount/ linewcom(20000)
+ if (iccount .le. 78) then
+ outq = lineq(1:78)
+ iposn = iccount
+ else
+ outq = '... '//lineq(55:128)
+ iposn = iccount-50
+ end if
+ print*
+ ibarnop = ibarno
+ if (linesinpmxmod.eq.0 .or.
+ * nline .gt. line1pmxmod+linesinpmxmod) then
+c
+c Error is in main .pmx file
+c
+c nlinep = nline-linesinpmxmod
+c Correct for comments not copied into buffer
+ nlinep = linewcom(nline)-linesinpmxmod
+ else
+c
+c Error is in include file
+c
+ ibarnop = 0
+ nlinep = nline-line1pmxmod+1
+ call printl(
+ * 'ERROR in include file named above, description given below')
+ end if
+ open(19,file='pmxaerr.dat')
+ write(19,'(i6)') nlinep
+ close(19)
+ ndigbn = max(1,int(log10(ibarnop+.1)+1))
+ ndignl = int(log10(nlinep+.1)+1)
+ lenmsg = index(msgq,'!')-1
+c
+c Split off msgq(..) since UNIX compilers don't allow concat substring!!!
+c
+ write(*,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)//
+ *',$)')' ERROR in line ',nlinep,', bar ',ibarnop
+ write(*,'(1x,a)')msgq(1:lenmsg)
+ write(15,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)//
+ *',$)')' ERROR in line ',nlinep,', bar ',ibarnop
+ write(15,'(a)')msgq(1:lenmsg)
+ i10 = iposn/10
+ i1 = iposn-10*i10
+ write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v'
+ write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v'
+ print*,outq(1:78)
+ write(15,'(a)')' '//outq(1:78)
+ write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^'
+ write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^'
+ return
+ end
+ subroutine eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk)
+c
+c Get elemskips to previous note. Called only for graces, no xtups involved.
+c
+ parameter (nm=24)
+ common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
+ * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
+ * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
+ * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
+ * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
+ * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
+ * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
+ * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
+ * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
+ character*1 ulq,sepsymq,sq
+ logical beamon,firstgulp,figbass,figchk,isfig
+ real*4 tstart(80),space(80)
+ common /comtol/ tol
+ itnd = nint(to(in))
+ if (ip.eq.1 .or. itnd.eq.itrpt) then
+c
+c Start of bar or after rpt.
+c
+ esk = fbar
+ return
+ else
+ esk = 0.
+ itprev = itnd-nodur(ivx,ip-1)
+ do 1 iib = ib , 1 , -1
+ if (tstart(iib) .lt. itprev+tol) then
+c
+c This is the block
+c
+ nnsk = nint(float((itnd-itprev))/space(iib))
+ esk = esk+nnsk*feon(space(iib))
+ return
+ else
+ nnsk = nint((itnd-tstart(iib))/space(iib))
+ esk = esk+nnsk*feon(space(iib))
+ itnd = nint(tstart(iib))
+ end if
+1 continue
+ end if
+ print*,'Problem in eskb4. Send files to Dr. Don'
+ stop
+ end
+ function f1eon(time)
+ f1eon = sqrt(time/2)
+ return
+ end
+ function feon(time)
+ common /comeon/ eonk,ewmxk
+ feon = sqrt(time/2)**(1.-eonk)*ewmxk
+ return
+ end
+ subroutine findbeam(ibmrep,numbms,mapfb)
+c
+c Called once per voice per bar, after setting forced beams.
+c
+ parameter (nm=24)
+ dimension mask(49,3),nummask(3),eqonly(49,3)
+c integer numbms(nm),ipr(48),nip1(0:47),nip2(0:47),mapfb(24),
+c * itr(48),nodue(48)
+c logical short(48),eqonly
+ integer numbms(nm),ipr(248),nip1(0:247),nip2(0:247),mapfb(24),
+ * itr(248),nodue(248)
+ logical short(248),eqonly
+ common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
+ * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
+ * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
+ * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
+ * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
+ * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
+ * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
+ * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
+ * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
+ common /comipl2/ ipl2(nm,200)
+ common /combeam/ ibmtyp
+ common /commvl/ nvmx(nm),ivmx(nm,2),ivx
+ common /comtol/ tol
+ character*1 ulq,sepsymq,sq
+ logical beamon,firstgulp,figbass,figchk,
+ * isfig,btest
+ data nip1,nip2 /496*0/
+ data nummask / 29 , 49 , 12 /
+ data mask
+ * / 65535, 4095, 65520, 255, 65280, 63,
+ * 252, 16128, 64512, 15, 240, 3840,
+ * 61440, 7, 14, 112, 224, 1792,
+ * 3584, 28672, 57344, 3, 12, 48,
+ * 192, 768, 3072, 12288, 49152, 20*0 ,
+ * 16777215, 65535, 16776960, 4095, 65520, 1048320,
+ * 16773120, 255, 65280, 16711680, 63, 252,
+ * 16128, 64512, 4128768, 16515072, 15, 60,
+ * 240, 3840, 15360, 61440, 983040, 3932160,
+ * 15728640, 7, 14, 112, 224, 1792,
+ * 3584, 28672, 57344, 458752, 917504, 7340032,
+ * 14680064, 3, 12, 48, 192, 768,
+ * 3072, 12288, 49152, 196608, 786432, 3145728,
+ * 12582912,
+ * 4095, 255, 4080, 15, 240, 3840,
+ * 3, 12, 48, 192, 768, 3072,
+ * 37*0 /
+ data eqonly /3*.true.,46*.false.,7*.true.,91*.false./
+ ip = 0
+ nreal = 0
+ itnow = 0
+1 continue
+ ip = ip+1
+ if (ip .gt. nn(ivx)) go to 9
+11 if (nodur(ivx,ip).eq.0) then
+c
+c Ignore all xtup notes except the last, the one with nodur > 0 .
+c Xtups are irrelevant here since they are already all in forced beams.
+c Will update itnow by nodur at the END of this loop
+c
+ ip = ip+1
+ go to 11
+ end if
+ nreal = nreal+1
+ nodue(nreal) = nodur(ivx,ip)
+ short(nreal) = nodue(nreal).lt.16 .and.
+ * .not.btest(irest(ivx,ip),0)
+c
+c Rule out notes that have 'alone'-flag set
+c
+ * .and..not.btest(islur(ivx,ip),18)
+ ipr(nreal) = ip
+ itr(nreal) = itnow
+ if (nodue(nreal) .eq. 1) then
+c
+c 64th gap
+c
+ if (mod(itnow,2) .eq. 0) then
+c
+c Start of 32nd gap, lump with following note
+c
+ ip = ip+1
+ nodue(nreal) = 1+nodur(ivx,ip)
+ itnow = itnow+nodue(nreal)
+ else
+c
+c End of 32nd gap, lump with preceeding note
+c
+ nreal = nreal-1
+ nodue(nreal) = 1+nodue(nreal)
+ itnow = itnow+1
+ end if
+ else
+ itnow = itnow+nodur(ivx,ip)
+ end if
+ go to 1
+9 continue
+ ir1 = 1
+ itseg = lenbar/ibmrep
+ do 13 irep = 1 , ibmrep
+c
+c Set bitmaps for all shorts neighbored by a short. Each bit represents a
+c span of 32nd note. maps, mapm, mape record start, full duration, and end
+c of consecutive span of beamable (<1/4) notes.
+c
+ maps = 0
+ mapm = 0
+ mape = 0
+ itend = itseg*irep
+ itoff = itend-itseg
+ do 2 ir = ir1 , nreal
+ it2 = itr(ir)+nodue(ir)-2
+ if (it2 .ge. itend) then
+ ir1 = ir
+ go to 14
+ end if
+c if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal
+ if (short(ir).and.((ir.gt.1.and.short(max(ir-1,1))).or.
+ * (ir.lt.nreal.and.short(ir+1)))) then
+ ib1 = (itr(ir)-itoff)/2
+ ib2 = (it2-itoff)/2
+ if (max(ib1,ib2).gt.47 .or. ir.gt.48 .or.
+ * min(ib1,ib2).lt.0) return
+c if (max(ib1,ib2).gt.247 .or. ir.gt.248 .or.
+c * min(ib1,ib2).lt.0) return
+c
+c Must have an odd number obe beats in a long bar. Auto-beam won't work
+c
+ nip1(ib1) = ipr(ir)
+ nip2(ib2) = ipr(ir)
+c
+c nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip
+c
+ maps = ibset(maps,ib1)
+ mape = ibset(mape,ib2)
+ do 3 ib = ib1 , ib2
+ mapm = ibset(mapm,ib)
+3 continue
+ end if
+2 continue
+14 continue
+ if (mapm .eq. 0) go to 13
+c
+c Zero out bits from forced beams
+c
+ maps = iand(maps,not(mapfb(irep)))
+ mapm = iand(mapm,not(mapfb(irep)))
+ mape = iand(mape,not(mapfb(irep)))
+c
+c Compare map with template.
+c
+ do 4 it = 1 , nummask(ibmtyp)
+ masknow = mask(it,ibmtyp)
+ if (iand(masknow,mapm) .eq. masknow) then
+c
+c Find least significant bit in the mask to check start time
+c
+ mtemp = masknow
+ maskm = masknow
+ do 5 is1 = 0 , 47
+c do 5 is1 = 0 , 247
+ if (iand(1,mtemp) .eq. 1) go to 6
+ mtemp = ishft(mtemp,-1)
+5 continue
+6 continue
+ if (iand(ishft(1,is1),maps) .eq. 0) go to 4
+c
+c is1 is the bit where the beam starts. Continue shifting to
+c find most significant bit in the mask to check ending time
+c
+ do 7 is2 = is1 , 47
+c do 7 is2 = is1 , 247
+ mtemp = ishft(mtemp,-1)
+ if (iand(1,not(mtemp)) .eq. 1) go to 8
+7 continue
+8 continue
+c
+c is2 is now the bit on which the beam ends.
+c
+ if (iand(ishft(1,is2),mape) .eq. 0) go to 4
+c
+c Did we pick out a single note from the middle of a longer sequence?
+c
+ if (nip1(is1) .eq. nip2(is2)) go to 4
+c
+c We almost have a beam. Check equality of notes if needed.
+c
+ if (eqonly(it,ibmtyp)) then
+ do 10 ip = nip1(is1) , nip2(is2)
+ if (nodur(ivx,ip) .ne. 8) then
+c
+c There is a non-1/8th note in this beam. Exit if not 2 quarters
+c
+ if (is2-is1 .ne. 15) go to 4
+c
+c Beam is 2 quarters long. Check if can split in half.
+c
+ ithalf = 0
+ do 20 iip = nip1(is1) , nip2(is2)
+ ithalf = ithalf+nodur(ivx,iip)
+ if (ithalf .gt. 16) go to 4
+ if (ithalf .eq. 16) go to 21
+20 continue
+ print*,'Problem in findbeam, please call Dr. Don'
+ go to 4
+21 continue
+c
+c Otherwise, split in half by keeping only the first half. Other half will
+c be picked up later, assuming masks are listed longest first.
+c
+ is2 = is1+7
+c
+c Reset maskm (since only used part of mask), used later to zero out
+c bits that contain beams
+c
+ maskm = 0
+ do 15 is = is1 , is2
+ maskm = ibset(maskm,is)
+15 continue
+ go to 16
+ end if
+10 continue
+ end if
+16 continue
+c
+c This is a beam. If last "effective" ends on odd 64th, add 1 more
+c
+c if (abs(mod(to(iand(255,ipl(ivx,nip2(is2))))
+c * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then
+ if (abs(amod(to(ipl2(ivx,nip2(is2)))
+ * +nodur(ivx,nip2(is2))+.5*tol,2.)) .gt. tol) then
+ nip2(is2) = nip2(is2)+1
+ end if
+ numbms(ivx) = numbms(ivx)+1
+ numnew = numbms(ivx)
+ call logbeam(numnew,nip1(is1),nip2(is2))
+c
+c Zero out the appropriate bits so these notes don't get used again
+c
+ mapm = iand(mapm,not(maskm))
+ if (mapm.eq.0) go to 13
+ maps = iand(maps,not(maskm))
+ mape = iand(mape,not(maskm))
+ end if
+4 continue
+13 continue
+ return
+ end
+ subroutine findeonk(nptr1,nptr2,wovera,xelsk,dtmin,dtmax,eonk0)
+ parameter (nkb=3999,maxblks=9600)
+c
+c Compute an exponent eonk for use in the "flattened" formula for elemskips
+c vs time. We must solve the eqution f = 0. Initial quess is eonk0.
+c
+ common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
+ * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
+ * ibaroff,udsp(nkb),wheadpt,sqzb(maxblks)
+ common /comtol/ tol
+ common /comeon/ eonk,ewmxk
+ eonk = eonk0
+ niter = 0
+1 continue
+ ewmxk = f1eon(dtmax)**eonk
+ niter = niter+1
+ esum = 0.
+ desum = 0.
+ do 2 iptr = nptr1 , nptr2
+ targ = durb(iptr)/sqzb(iptr)
+ esum = esum+nnpd(iptr)*sqzb(iptr)*feon(targ)
+ detarg = sqrt(targ/2*(dtmax/targ)**eonk)*alog(dtmax/targ)
+ desum = desum+nnpd(iptr)*sqzb(iptr)*detarg
+2 continue
+ f = wovera*feon(dtmin)-xelsk-esum
+ fp = wovera*sqrt(dtmin/2*(dtmax/dtmin)**eonk)*alog(dtmax/dtmin)
+ * -desum
+ if (abs(fp).lt.tol .or. abs(eonk-.5).gt..5 .or. niter.gt.100) then
+ call printl(
+ * 'Error in findeonk. Please send source to Dr. Don')
+ eonk = 0.
+ ewmxk = 1.
+ return
+ end if
+ dsoln = -f/fp
+ if (abs(dsoln) .lt. .1*tol) return
+c
+c Not converged yet, try again
+c
+ eonk = eonk+dsoln
+ go to 1
+ end
+ function fnote(nodur,ivx,ip,nacc)
+c
+c This return the real duration of a note
+c
+ parameter (nm=24)
+ integer*4 nodur(nm,200),nacc(nm,200)
+ logical btest
+ ipback = ip
+ if (nodur(ivx,ip) .gt. 0) then
+ if (ip .gt. 1) then
+c
+c Check if this is last note of xtup
+c
+ if (nodur(ivx,ip-1).eq.0) then
+ ipback = ip-1
+ go to 2
+ end if
+ end if
+ fnote = nodur(ivx,ip)
+ return
+ end if
+2 continue
+c
+c Count back to prior non zero note. Start at ip to avoid neg index if ip=1.
+c Count how many doubled xtups notes there are from ip-1 to first note.
+c
+ ndoub = 0
+ do 1 ip1m1 = ipback , 1 , -1
+ if (nodur(ivx,ip1m1) .gt. 0) go to 4
+ if (ip1m1.lt.ip .and. btest(nacc(ivx,ip1m1),18)) ndoub=ndoub+1
+1 continue
+4 continue
+c
+c count forward to next non-0 nodur. Start at ip in case last note of xtup.
+c
+ do 3 iip = ip , 200
+c
+c Count doubled xtup notes from ip to end.
+c
+ if (btest(nacc(ivx,iip),18)) ndoub = ndoub+1
+ if (nodur(ivx,iip) .gt. 0) then
+c fnote = nodur(ivx,iip)/float(iip-ip1m1)
+ fnote = nodur(ivx,iip)/float(iip-ip1m1+ndoub)
+ if (btest(nacc(ivx,ip),18)) then
+ fnote = 2*fnote
+ else if (btest(nacc(ivx,ip),27)) then
+ fnote = 1.5*fnote
+ else if (ip .gt. 1) then
+ if (btest(nacc(ivx,ip-1),27)) fnote = .5*fnote
+ end if
+ return
+ end if
+3 continue
+ print*,' '
+ call printl
+ * ('Probable misplaced barline or incorrect meter, stopping')
+ print*,'ivx,ip:',ivx,ip
+ call stop1()
+ end
+ subroutine g1etchar(lineq,iccount,charq)
+ parameter(nm=24)
+ common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
+ * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
+ logical lastchar,issegno,isheadr,isvolt,fbon
+ common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
+ logical mrecord,mplay,endmac
+ character*1 charq
+ character*128 lineq,lnholdq
+c
+c Gets the next character out of lineq*128. If pointer iccount=128 on entry,
+c then reads in a new line. Resets iccount. Ends program if no more input.
+c
+ if (iccount .eq. 128) then
+ call read10(lineq,lastchar)
+ if (lastchar) return
+ if (.not.endmac) then
+ iccount = 0
+ if (.not.mplay) nline = nline+1
+ else
+ endmac = .false.
+ iccount = icchold
+ lineq = lnholdq
+ end if
+ if (mrecord) then
+ call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
+ end if
+ end if
+ iccount = iccount+1
+ charq = lineq(iccount:iccount)
+ return
+ end
+ subroutine g1etnote(loop,ifig,optimize,fulltrans)
+ parameter (nm=24,nkb=3999,mv=24576,maxblks=9600)
+ character*1 chax
+ logical twotrem
+ common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm),
+ * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
+ * nbars,itsofar(nm),nib(nm,15),nn(nm),
+ * rest(nm,200),lenbr0,lenbr1,firstline,newmeter
+ common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
+ * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
+ * ibaroff,udsp(nkb),wheadpt,sqzb(maxblks)
+ common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
+ * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
+ common /compage/ widthpt,ptheight,hoffpt,voffpt,
+ * nsyst,nflb,ibarflb(0:40),
+ * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
+ * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30),
+ * nistaff(0:40)
+ common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200)
+ common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1,
+ * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS
+ logical lastchar,firstline,rest,loop,newmeter,fbon,issegno,barend,
+ * isheadr,fulbrp,usefig,isvolt,iskchb,kchmid,plusmin,ornrpt,
+ * stickyS
+ common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
+ common /commus/ musize,whead20
+ logical mrecord,mplay,endmac,shifton,optimize
+ character*128 lineq,lnholdq
+ character*1 charq,dotq,dumq,durq,charlq
+ integer*2 mmidi
+ logical restpend,relacc,notmain,twoline,ismidi,crdacc,cdot
+ common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
+ * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
+ * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
+ * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
+ * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
+ * debugmidi
+ logical debugmidi
+ character*131072 bufq
+ integer*2 lbuf(maxblks)
+ common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
+ logical novshrinktop,upslur,fontslur,ztrans,
+ * WrotePsslurDefaults,cstuplet
+ common /comnvst/ novshrinktop,cstuplet
+ common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
+ * ,WrotePsslurDefaults,SlurCurve
+ character*51 literq(3),lyrerq(5)
+ common /comligfont/ isligfont
+ logical isligfont
+ common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
+ * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
+ logical EarlyTransOn,LaterInstTrans
+ logical fulltrans
+ common /comsize/ isize(nm)
+ common /commidisig/ midisig
+ common /comis4bignv/ is4bignv,AIset
+ logical is4bignv,AIset
+ common /comshort/ shortfrac,codafrac,ishort,mbrsum,nmbr,nocodabn,
+ * poefa
+ real*4 poefa(125)
+ logical nocodabn
+ data literq
+ * /'Literal TeX string cannot start with 4 backslashes!',
+ * 'TeX string must have <129 char, end with backslash!',
+ * 'Type 2 or 3 TeX string can only start in column 1!'/
+ data lyrerq
+ * /'pmxlyr string must end with " followed by blank!',
+ * 'pmxlyr string cannot extend past position 120!',
+ * 'There must be "a" or "b" here!',
+ * 'There must be "+" or "-" here!',
+ * 'There must be an integer here!'/
+ cdot = .false.
+ twotrem = .false.
+1 call g1etchar(lineq,iccount,charq)
+ if (charq .ne. ' ') charlq = charq
+ if (lastchar) then
+ if (index('/%',charlq) .eq. 0) then
+ print*
+ print*,'WARNING:'
+ print*,'Last non-blank character is "',charlq,'", not "/,%"'
+ print*,'ASCII code:',ichar(charlq)
+ write(15,'(/a)')'Last non-blank character is "'//charlq//
+ * '", not "/,%"'
+ write(15,'(a11,2x,i3)')'ASCII code:',ichar(charlq)
+c
+c Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1.
+c
+ ilbuf = ilbuf-1
+ lbuf(ilbuf) = lbuf(ilbuf)+2
+ bufq = bufq(1:ipbuf)//' /'
+ write(15,*)'appending <blank>/'
+ print*,'appending <blank>/'
+ lineq = lineq(1:iccount)//' /'
+ lastchar = .false.
+ go to 1
+ end if
+ return
+ end if
+ if (charq .eq. ' ') then
+ go to 1
+ else if (charq.eq.'%' .and. iccount.eq.1) then
+ iccount = 128
+ go to 1
+c
+c Replacement 1/22/12 since gfortran 4.7 with -O was choking here!
+c
+c else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or.
+ else if (index('abcdefg',charq).gt.0 .or.
+ * charq.eq.'r') then
+c
+c This is a note/rest.
+c
+ if (cdot) go to 28
+ idotform = 0
+ numnum = 0
+ plusmin = .false.
+28 nnl(ivx) = nnl(ivx)+1
+ if (nnl(ivx) .gt. 200) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * '>200 notes in line of music. Use smaller blocks!')
+ call stop1()
+ end if
+ dotq = 'x'
+c
+c Check if this is 'r ' and previous note was full-bar-pause
+c
+ fulbrp = charq.eq.'r' .and. lineq(iccount+1:iccount+1) .eq.' '
+ * .and. nnl(ivx).gt.1 .and. rest(ivx,max(1,nnl(ivx)-1)) .and.
+ * nodur(ivx,max(1,nnl(ivx)-1)) .eq. lenbar
+2 call g1etchar(lineq,iccount,durq)
+ ic = ichar(durq)
+ if (ic.le.57 .and. ic.ge.48) then
+c
+c Digit
+c
+ if (numnum .eq. 0) then
+ nnodur = ic-48
+ numnum = 1
+ go to 2
+ else if (numnum .eq. 1) then
+ if (charq .eq. 'r') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Only one digit allowed after rest symbol "r"!')
+ call stop1()
+ end if
+ numnum = 2
+ if (plusmin) then
+ print*
+ print*,'*********WARNING*********'
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Before version 1.2, +/- was ignored if octave was!')
+ print*,
+ * 'explicitly specified. May need to edit old editions'
+ end if
+ go to 2
+ else
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * '>2 digits in note symbol!')
+ call stop1()
+ end if
+ else if (durq.eq.'d') then
+ dotq = durq
+ if (lineq(iccount+1:iccount+1) .eq. 'd') then
+ iddot = 1
+ iccount = iccount+1
+c
+c Since we flow out, double dots won't work with other dot options
+c
+ end if
+ if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
+c
+c move a dot, provided a number follows.
+c
+ call g1etchar(lineq,iccount,durq)
+ call g1etchar(lineq,iccount,durq)
+ if (index('0123456789-.',durq) .eq. 0) then
+c
+c Backup, exit the loop normally
+c
+ iccount = iccount-2
+ go to 2
+ end if
+ call readnum(lineq,iccount,dumq,fnum)
+ if (index('+-',dumq) .gt. 0) then
+c
+c Vertical shift also
+c
+ call g1etchar(lineq,iccount,durq)
+ if (index('0123456789-.',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected number after 2nd +/- (shift dot)!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ end if
+ iccount = iccount-1
+ end if
+ go to 2
+ else if (index('<>',durq) .gt. 0) then
+c
+c Accidental shift
+c
+c if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then
+ if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+c * 'Expected "f", "s", or "n" before "<" or ">"!')
+ * 'Expected "f", "s", "n" or "A" before "<" or ">"!')
+ call stop1()
+ end if
+ ipm = 1
+ if (durq .eq. '<') ipm=-1
+ call g1etchar(lineq,iccount,durq)
+ if (index('123456789.0',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected number after </> (accidental shift)!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ fnum = ipm*fnum
+ if (fnum.lt.-5.35 .or. fnum.gt.1.0) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Horizontal accidental shift must be >-5.35 and <1.0!')
+ call stop1()
+ end if
+ iccount = iccount-1
+ go to 2
+ else if (index('+-',durq) .gt. 0) then
+ if (charq .ne. 'r') then
+ if (index('fsnA',lineq(iccount-1:iccount-1)) .gt. 0) then
+ ipm = 1
+ if (durq .eq. '-') ipm=-1
+ if (index('0123456789',lineq(iccount+1:iccount+1))
+ * .gt.0) then
+c
+c This may be start of accidental shift, but may be octave jump; then duration
+c
+ icsav = iccount
+ iccount = iccount+1
+ call readnum(lineq,iccount,durq,fnum)
+ if (index('+-',durq) .gt. 0) then
+c
+c This is an accid shift since there's a 2nd consecutive signed number.
+c Check size of 1st number.
+c
+ if (fnum .gt. 30.5) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Vertical accidental shift must be less than 31!')
+ call stop1()
+ end if
+ ipm = 1
+ if (durq .eq. '-') ipm = -1
+ call g1etchar(lineq,iccount,durq)
+ if (index('1234567890.',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected 2nd number of accidental shift)!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ fnum = ipm*fnum
+ if (fnum.lt.-5.35 .or. fnum.gt.1.0) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Horiz. accidental shift must be >-5.35 and <1.0!')
+ call stop1()
+ end if
+ iccount = iccount-1
+ go to 2
+ else
+c
+c Not accid shift, reset, then flow out
+c
+ iccount = icsav
+ end if
+ end if
+ end if
+ plusmin = .true.
+ if (numnum .eq. 2) then
+ print*
+ print*,'*********WARNING*********'
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Before version 1.2, +/- was ignored if octave was!')
+ print*,
+ * 'explicitly specified. May need to edit old editions'
+ end if
+ go to 2
+c
+c It's a rest containing +|- . Must refer to a vertical shift. Read past.
+c
+ else
+ call g1etchar(lineq,iccount,durq)
+ call readnum(lineq,iccount,durq,dum)
+ if (lineq(iccount-1:iccount-1).eq.'.') iccount=iccount-1
+ iccount = iccount-1
+ go to 2
+ end if
+c else if (index('ulare',durq) .gt. 0) then
+ else if (index('ularec',durq) .gt. 0) then
+ go to 2
+ else if (index('LS',durq) .gt. 0) then
+c
+c Stemlength change
+c
+ call g1etchar(lineq,iccount,durq)
+ if (index('.0123456789:',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'There must be a number or colon here!')
+ call stop1()
+ end if
+ if (durq .eq. ':') then
+ if (.not.stickyS) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Turned off sticky stemlegth changes without turning on!')
+ call stop1()
+ end if
+ stickyS = .false.
+ go to 2
+ end if
+ call readnum(lineq,iccount,durq,dum)
+c if (dum.lt..5 .or. dum.gt.4.) then
+ if ((durq.eq.'L'.and.dum.gt.20.).or.
+ * (durq.eq.'S'.and.dum.gt.4.)) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Stemlength change amount too big!')
+ call stop1()
+ end if
+ if (durq .ne. ':') then
+ iccount = iccount-1
+ else
+ if (stickyS) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Turned on sticky stemshrinks when already on!')
+ call stop1()
+ end if
+ stickyS = .true.
+ end if
+ go to 2
+ else if (index('fsn',durq) .gt. 0) then
+c
+c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so
+c MUST come right after "f,s,n"
+c
+ if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
+ go to 2
+ else if (durq .eq. 'p') then
+ fulbrp = charq.eq.'r'
+ if (.not. fulbrp) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'The option "p" only works with "r" (rest)!')
+ call stop1()
+ end if
+ go to 2
+ else if (durq .eq. 'b') then
+ if (charq .ne. 'r') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'You entered "b"; I expected "rb"!')
+ call stop1()
+ else if (numnum .eq. 2) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'You entered "r" & "b" with two numbers!')
+ end if
+ go to 2
+ else if (durq .eq. 'x') then
+c
+c Xtuplet. Count number of doubled notes (for unequal xtups)
+c
+ if (btest(nacc(ivx,nnl(ivx)),18)) then
+ ndoub = 1
+ else
+ ndoub = 0
+ end if
+c
+c Will set all durations to 0 except last one.
+c
+ call g1etchar(lineq,iccount,durq)
+ if (index('123456789T',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'First char after "x" in xtuplet must be "1"-"9" or "T"!')
+ call stop1()
+ end if
+ if (durq .eq. 'T') then
+c
+c Set a flag for checking 2nd note inputs if dot is moved
+c
+ twotrem = .true.
+c
+c Check all x-tremolo inputs here; set fnum=2
+c
+ fnum = 2
+ call getchar(lineq,iccount,durq)
+ if (index('0123 ',durq).eq.0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'First char after "T" in xtuplet must be "0"-"3" or blank!')
+ call stop1()
+ else if (durq .ne. ' ') then
+ call getchar(lineq,iccount,durq)
+ if (index('0123 ',durq).eq.0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'This char must be "0"-"3" or blank!')
+ call stop1()
+ else if (durq .ne. ' ') then
+ call getchar(lineq,iccount,durq)
+c
+c Probably blank unles other options entered
+c
+ end if
+ end if
+ else
+c
+c durq is digit, normal xtup
+c
+ call readnum(lineq,iccount,durq,fnum)
+c
+c Leaves durq at next char after number
+c
+ if (fnum .gt. 99) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Xtuplet cannot have more than 99 notes!')
+ call stop1()
+ else if (index(' DFnd',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Only legal characters here are " ","D","F","n"!')
+ call stop1()
+ end if
+ end if
+c
+c End of mandatory xtup inputs. Check for options. Note D,F,d must precede n.
+c
+ if (index('DF',durq) .gt. 0) then
+c
+c Double xtup note to make an un= xtup. Here, number already set, but may also
+c have used this before number was set.
+c
+ nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
+ ndoub = 1
+ call g1etchar(lineq,iccount,durq)
+ else if (durq .eq. 'd') then
+ nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
+ call g1etchar(lineq,iccount,durq)
+ end if
+ if (durq .eq. 'n') then
+c
+c Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'.
+c
+ numshft = 0
+30 call g1etchar(lineq,iccount,durq)
+ if (durq .eq. 'f') then
+ go to 30
+ else if (index('+-',durq) .gt. 0) then
+ numshft = numshft+1
+ if (numshft .eq. 3) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Only 2 shifts are allowed after "n" in xtup!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,durq)
+ if (index('0123456789.',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'This character should be a digit or "."!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,snum)
+ iccount = iccount-1
+c if ((numshft.eq.1 .and. snum.gt.15.1) .or.
+ if ((numshft.eq.1 .and. snum.gt.64.) .or.
+ * (numshft.eq.2 .and. snum.gt.1.51)) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Shift number after "n" in xtup is out of range!')
+ call stop1()
+ end if
+ go to 30
+ else if (durq .eq. 's') then
+c
+c Slope alteration for bracket
+c
+ call getchar(lineq,iccount,durq)
+ if (index('+-',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'For slope adjustment, this character must be "+" or "-"!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,durq)
+ if (index('123456789',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'This character should be a digit!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,snum)
+ iccount = iccount-1
+ if (nint(snum) .gt. 15) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Slope adjustment cannot exceed 15!')
+ call stop1()
+ end if
+ go to 30
+ else if (index('123456789',durq) .gt. 0) then
+c
+c Unsigned integer => alternate printed number
+c
+ call readnum(lineq,iccount,durq,snum)
+ if (snum .gt. 15.1) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Alternate xtup number after "n" must be <16!')
+ call stop1()
+ end if
+ iccount = iccount-1
+ go to 30
+ else if (durq .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character after "n" in xtup!')
+ call stop1()
+ end if
+ end if
+ ntup = nint(fnum)
+ do 6 itup = 2 , ntup
+ nodur(ivx,nnl(ivx)) = 0
+ nnl(ivx) = nnl(ivx)+1
+110 call g1etchar(lineq,iccount,durq)
+ if (durq.eq.' ') then
+ go to 110
+ else if (durq .eq. 'o') then
+c
+c Ornament in xtup. "o" symbol must come AFTER the affected note
+c
+ call g1etchar(lineq,iccount,dumq)
+ if (index('(stmx+Tup._)e:>^bc',dumq) .eq. 0 ) then
+ if (index('fg',dumq) .gt. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Fermata or segno not allowed in xtuplet!')
+ else
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal ornament!')
+ end if
+ call stop1()
+ end if
+ if (dumq .eq. 'T') then
+c
+c Trill. may be followed by 't' and/or number. read 'til blank
+c
+29 call g1etchar(lineq,iccount,dumq)
+ if (dumq .ne. ' ') go to 29
+ else if (dumq .eq. 'e') then
+ call g1etchar(lineq,iccount,dumq)
+ if (index('sfn?',dumq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character after "e" in edit. accid. symbol!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,dumq)
+ if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq)
+ else if (dumq .eq. ':') then
+ if (lineq(iccount+1:iccount+1) .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * '":" must be followed by blank in "o: "!')
+ call stop1()
+ else if (.not.ornrpt) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Turned off repeated ornaments before they were on!')
+ call stop1()
+ end if
+ ornrpt = .false.
+ else
+ call g1etchar(lineq,iccount,dumq)
+ end if
+ if (index('+- :',dumq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character in ornament symbol!')
+ call stop1()
+ end if
+ if (dumq .eq. ':') then
+ if (lineq(iccount+1:iccount+1) .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * '":" must be followed by blank in "o: "!')
+ call stop1()
+ else if (ornrpt) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Turned on repeated ornaments but already on!')
+ call stop1()
+ end if
+ ornrpt = .true.
+ end if
+ if (index('+-',dumq) .gt. 0) then
+ if (index('0123456789',lineq(iccount+1:iccount+1))
+ * .eq. 0) then
+ call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
+ * 'There should be an integer here!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ if (durq .eq. ':') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Cannot shift AND repeat an ornament!')
+ call stop1()
+ end if
+c
+c 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas.
+c
+ if (index('+-',durq) .gt. 0) then
+ if (index('.0123456789',lineq(iccount+1:iccount+1))
+ * .eq. 0) then
+ call errmsg(lineq,iccount+1,
+ * ibarcnt-ibaroff+nbars+1,
+ * 'There should be a number here!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ end if
+ end if
+ go to 110
+ else if (index('st(){}',durq) .gt. 0) then
+c
+c Slur in xtup
+c
+ iposn = 0
+ numint = 0
+15 call g1etchar(lineq,iccount,dumq)
+ iposn = iposn+1
+ if (index('udlbfnhtv',dumq) .gt. 0) then
+ if (dumq.eq.'t' .and. durq.eq.'t') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Cannot use "t" as an option on a tie!')
+ call stop1()
+ end if
+ go to 15
+ else if (index('+-',dumq) .gt. 0) then
+ numint = numint+1
+ iccount = iccount+1
+ call readnum(lineq,iccount,durq,fnum)
+ if (numint .eq. 1) then
+ if (nint(fnum) .gt. 30) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Magnitude of slur height adjustment cannot exceed 30!')
+ call stop1()
+ end if
+ else if (numint .eq. 2) then
+ if (abs(fnum).gt.6.3) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Slur horiz shift must be in the range (-6.3,6.3)!')
+ call stop1()
+ end if
+ else
+c
+c Third signed integer, must be a midslur or curve spec.
+c
+ if (abs(fnum).gt.31) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Slur midheight must be in the range (-31,31)!')
+ call stop1()
+ end if
+ if (durq .eq. ':') then
+c
+c Expecting curve parameters. Get two numbers
+c
+ do 40 i = 1 , 2
+ iccount = iccount+1
+ fnum = ichar(lineq(iccount:iccount))-48
+ if (abs(fnum-3.5) .gt. 3.6) then
+ call errmsg(lineq,iccount,
+ * ibarcnt-ibaroff+nbars+1,
+ * 'Slur curve parameter must be in range (0,7)!')
+ call stop1()
+ end if
+40 continue
+ iccount = iccount+1
+ end if
+ end if
+ iccount = iccount-1
+ go to 15
+
+ else if (dumq .eq. 's') then
+c
+c What follows should be one or two signed numbers for adjustment of line break
+c slur, end of 1st segment or start of second.
+c
+ if (fontslur) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'May not use linebreak slur options with font-based slurs!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,dumq)
+ if (index('+-',dumq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'This character must be "+" or "-"!')
+ call stop1()
+ end if
+ iccount = iccount+1
+ call readnum(lineq,iccount,dumq,fnum)
+ if (nint(fnum) .gt. 30) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Magnitude of slur height adjustment cannot exceed 30!')
+ call stop1()
+ end if
+ if (index('+-',dumq) .gt. 0) then
+ iccount = iccount+1
+ call readnum(lineq,iccount,dumq,fnum)
+ if (abs(fnum) .gt. 6.3) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Slur horiz shift must be in range (-6.3,6.3)!')
+ call stop1()
+ end if
+ end if
+ iccount = iccount-1
+ go to 15
+ else if (dumq .eq. 'H' .and. iposn.gt.1) then
+ if (lineq(iccount+1:iccount+1) .eq. 'H')
+ * iccount=iccount+1
+ go to 15
+ else if (dumq .eq. 'p') then
+c
+c local change in postscript slur/tie adjustment default
+c
+ if (fontslur) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Must use postscript slurs ("Ap") to use this option!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,dumq)
+ if (index('+-',dumq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected "+" or "-" here!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,dumq)
+ if (index('st',dumq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected "s" or "t" here!')
+ call stop1()
+ end if
+ go to 15
+ else if (dumq .ne. ' ') then
+ ic = ichar(dumq)
+ if ((ic.ge.48.and.ic.le.57) .or.
+ * (ic.ge.65.and.ic.le.90)) then
+ if (iposn .eq. 1) then
+ if (durq.eq.'t' .and. fontslur) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Slur ID not allowed on non-postscript tie!')
+ call stop1()
+ end if
+ if (lineq(iccount+1:iccount+1).eq.'x')
+ * iccount = iccount+1
+ go to 15
+ end if
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Slur ID must be 2nd character in slur symbol!')
+ call stop1()
+ end if
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character in slur symbol!')
+ call stop1()
+ end if
+ go to 110
+ else if (index('0123456789#-nx_',durq) .gt. 0) then
+c
+c We have a figure. Only allow on 1st note of xtup
+c
+ if (itup .ne. 2) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Figure in xtup only allowed on 1st note!')
+ call stop1()
+ else if (durq.eq.'x') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'No floating figures in xtuplets!')
+ call stop1()
+ end if
+ if (usefig .and. ivx.eq.1) ifig = 1
+26 call g1etchar(lineq,iccount,durq)
+c if (index('0123456789#-n_.:',durq) .gt. 0) then
+ if (index('0123456789#-n_.:v',durq) .gt. 0) then
+ go to 26
+ else if (durq .eq. 's') then
+ isligfont = .true.
+ go to 26
+ else if (durq .eq. '+') then
+c
+c vertical offset, must be integer then blank
+c
+ call g1etchar(lineq,iccount,durq)
+ if (index('123456789',durq) .ne. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Integer for vertical offset expected here!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ if (durq .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Vertical offset must terminate figure!')
+ call stop1()
+ end if
+ iccount = iccount-1
+ go to 26
+ else if (durq .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character in figure in xtuplet!')
+ call stop1()
+ end if
+ go to 110
+ else if (durq .eq. 'G') then
+ ngr = 1
+79 call g1etchar(lineq,iccount,charq)
+ if (index('123456789',charq) .gt. 0) then
+ call readnum(lineq,iccount,durq,fnum)
+ ngr = nint(fnum)
+ iccount = iccount-1
+ go to 79
+ else if (index('AWulxs',charq) .gt. 0) then
+ go to 79
+ else if (charq .eq. 'm') then
+ call g1etchar(lineq,iccount,charq)
+ if (index('01234',charq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'A digit less than 5 must follow "m" in a grace note!')
+ call stop1()
+ end if
+ go to 79
+ else if (charq .eq. 'X') then
+c
+c Space before main note
+c
+ call g1etchar(lineq,iccount,charq)
+ if (index('0123456789.',charq) .gt. 0) then
+ call readnum(lineq,iccount,durq,fnum)
+ iccount = iccount-1
+ go to 79
+ else
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'A number must follow "X" in a grace note!')
+ call stop1()
+ end if
+ end if
+c
+c At this point, charq is first note name in rest (grace?)
+c
+ do 71 igr = 1 , ngr
+ numnum = 0
+ if (igr .gt. 1) then
+75 call g1etchar(lineq,iccount,charq)
+ if (charq .eq. ' ') go to 75
+ end if
+ if (index('abcdefg',charq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'In grace, expected "a"-"g"!')
+ call stop1()
+ end if
+78 call g1etchar(lineq,iccount,charq)
+ if (charq .ne. ' ') then
+ if (index('1234567',charq) .gt. 0) then
+ if (numnum .eq. 1) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Only one of "+-1234567" allowed here in grace!')
+ call stop1()
+ end if
+ numnum = 1
+ go to 78
+ else if (index('+-nfs',charq) .gt. 0) then
+ go to 78
+ end if
+c
+c Digits are possible octave numbers
+c
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character after note name in grace!')
+ call stop1()
+ end if
+71 continue
+ go to 110
+ else if (durq .eq. chax(92)) then
+ call chklit(lineq,iccount,literr)
+ if (literr .gt. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * literq(literr))
+ call stop1()
+ end if
+ go to 110
+ else if (durq .eq. chax(34)) then
+c
+c pmx lyric
+c
+ call chkpmxlyr(lineq,iccount,lyrerr)
+ if (lyrerr .gt. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * lyrerq(lyrerr))
+ call stop1()
+ end if
+ go to 110
+ else if (durq .eq. 'M') then
+c
+c Temporary trap until I get around putting this in pmxb
+c
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Macros not yet allowed in xtuplets!')
+ call stop1()
+ else if (durq .eq. 'X') then
+ call g1etx(lineq,iccount,shifton,
+ * ibarcnt-ibaroff+nbars+1,udsp(ibarcnt+nbars+1),wheadpt)
+ go to 110
+ else if (durq .eq. 'z') then
+c
+c Chord note in xtup. Read past for now.
+c
+33 call g1etchar(lineq,iccount,durq)
+ if (durq .ne. ' ') go to 33
+ go to 110
+ else if (durq .eq. 'D') then
+c
+c Dynamic mark
+c
+ call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1)
+ go to 110
+ else if (durq .eq. '%') then
+ if (iccount .ne. 1) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Comment must have "%" in column 1!')
+ call stop1()
+ end if
+ iccount = 128
+ go to 110
+ else if (durq .eq. '?') then
+ call getchar(lineq,iccount,durq)
+ if (durq .eq. ' ') then
+ iccount = iccount-1
+ go to 110
+ end if
+ if (durq .ne. '-') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expecting "-"')
+ call stop1()
+ end if
+ call getchar(lineq,iccount,durq)
+ if (index('0123456789.',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expecting number')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ iccount = iccount-1
+ go to 110
+c
+c 140215 Allow clef change inside xtup
+c
+ else if (durq .eq. 'C') then
+ call g1etchar(lineq,iccount,durq)
+ if (.not.(index('tsmanrbf',durq).gt.0 .or.
+c * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then
+ * (ichar(durq).ge.48 .and. ichar(durq).le.56))) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Must have t,s,m,a,n,r,b,f or 0-8 after C!')
+ call stop1()
+ end if
+ go to 110
+c+++
+ else if (durq.eq.']' .and. lineq(iccount+1:iccount+1).eq.'['
+ * .and. lineq(iccount+2:iccount+2).eq.' ') then
+ iccount = iccount+2
+ go to 110
+c+++
+c
+c Added 200118 to allow dot to be moved on 2nd note of 2-note tremolo
+c
+ end if
+c
+c End of xtup options. At this point symbol can only be note or rest
+c
+ if (index('abcdefgr',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'In xtup, this character is not allowed!')
+ call stop1()
+ end if
+7 call g1etchar(lineq,iccount,durq)
+ if (index('12345678ulcb',durq) .gt. 0) then
+ go to 7
+ else if (index('sfn',durq) .gt. 0) then
+c
+c Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift.
+c
+ if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
+ go to 7
+ else if (index('+-<>',durq) .gt. 0) then
+c
+c May have either octave jump or shifted accid. on main xtup note
+c
+ if (index('+-',durq).gt.0 .and.
+ * index('01234567890',lineq(iccount+1:iccount+1)).eq.0)
+ * go to 7
+ iccount = iccount+1
+ call readnum(lineq,iccount,durq,fnum)
+ iccount = iccount-1
+ go to 7
+ else if (index('DF',durq) .gt. 0) then
+c
+c Double an xtup note to make an unequal xtup
+c
+ nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
+ ndoub = ndoub+1
+ go to 7
+ else if (durq .eq. 'd') then
+ if (twotrem) then
+c
+c 2-note trem, get shift
+c
+ call g1etchar(lineq,iccount,durq)
+ if (index('+-',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected +/- for shifted dot on end of 2-note trem!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,durq)
+ if (index('0123456789.',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected number here!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,dumq,fnum)
+ if (index('+-',dumq) .gt. 0) then
+c
+c Vertical shift also
+c
+ call g1etchar(lineq,iccount,durq)
+ if (index('0123456789-.',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected number after 2nd +/- (shift dot)!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ end if
+ iccount = iccount-1
+ go to 7
+ else
+ nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
+ end if
+ go to 7
+ else if (durq .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal option on xtuplet note!')
+ call stop1()
+ end if
+ if (itup .eq. ntup-ndoub) go to 3
+6 continue
+3 continue
+c
+c 6==End of loop for xtuplet input
+c
+ else if (durq .eq. 'm') then
+c
+c Multi-bar rest: next 1 or two digits are # of bars.
+c
+ if (mod(itsofar(iv),lenbar) .ne. 0) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Multibar rest must start at beginning of bar!')
+ call stop1()
+ else if (iv.eq.1.and.ibarmbr.gt.0) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Multibar rest only OK at one time per block!')
+ call stop1()
+ end if
+c
+c For some purposes, pretend its one bar only
+c
+ nodur(iv,nnl(iv)) = lenbar
+ ibarmbr = nbars+1
+ mbrest = 0
+c20 call g1etchar(lineq,iccount,durq)
+ call g1etchar(lineq,iccount,durq)
+ if (index('123456789',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected an integer after "rm"!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ mbrest = nint(fnum)
+c iccount = iccount-1
+ if (nv .gt. 1) then
+ if (iv .eq. 1) then
+ mbrestsav = mbrest
+ else
+ if (mbrest .ne. mbrestsav) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Must enter same multi-bar rest in every voice!')
+ call stop1()
+ end if
+ end if
+c
+c Zero out mbrestsav so can check at end of input block whether
+c all voices have one
+c
+ if (iv .eq. nv) mbrestsav=0
+ end if
+ if (durq .eq. 'n') then
+c
+c Get new height
+c
+ call g1etchar(lineq,iccount,durq)
+ if (index('+-123456789',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected an integer after "rm[x]n"!')
+ call stop1()
+ end if
+ if (index('+-',durq).ne.0) iccount = iccount+1
+ call readnum(lineq,iccount,durq,fnum)
+ end if
+ if (durq .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character after "rm"!')
+ call stop1()
+ end if
+ else if (durq .eq. '.') then
+c
+c Dotted pattern. Close out note. Mult time by 3/4.
+c Set time for next note to 1/4. Start the note.
+c
+ idotform = 1
+ else if (durq .eq. ',') then
+ idotform = 3
+c
+c Now flow to duration setting, as if durq=' '
+c
+ else if (index('oL',durq) .gt. 0) then
+c
+c Suppress full bar rest, or look left for height
+c
+ if (charq .ne. 'r') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * '"o","L" options only legal for rest, not note!')
+ call stop1()
+ end if
+ go to 2
+ else if (index('DF',durq) .gt. 0) then
+c
+c Double note for xtup. Must check here in case "D" or "F" came before "x" or on
+c last note of xtup. Need to flag it in pmxa since affects horiz. spacing.
+c
+ nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
+ go to 2
+ else if (durq .eq. 'A') then
+c
+c Main note accidental option
+c
+ call getchar(lineq,iccount,durq)
+ if (index('o+-<>',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * '"o",+","-","<",">" are the only legal options here!')
+ call stop1()
+ end if
+c
+c Need more stuff here
+c
+ if (durq .ne. "o") then
+c
+c Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will
+c proceed to number input checking
+c
+ iccount = iccount-1
+ end if
+ go to 2
+ else if (durq .eq. 'T') then
+c
+c Single stem tremolo. Only option (optional) is 1,2,3, or 4.
+c
+ call getchar(lineq,iccount,durq)
+ if (index('1234',durq) .eq. 0) iccount = iccount-1
+ go to 2
+ else if (durq .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character!')
+ print*,'ASCII code:',ichar(durq)
+ call stop1()
+ end if
+c
+c End of block for note options.
+c
+c Set the duration
+c
+ if (idotform .gt. 0) then
+ if (idotform .eq. 1) then
+ nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)*3/2
+ else if (idotform .eq. 2) then
+ nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3
+ else if (idotform .eq. 3) then
+ nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)
+ else if (idotform .eq. 4) then
+ nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2
+ end if
+ else if (ibarmbr.ne.nbars+1 .and. .not.fulbrp) then
+ nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)
+c
+c Check for double dot
+c
+ if (iddot .eq. 1) then
+ nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6
+ iddot = 0
+ end if
+ else if (fulbrp) then
+ nodur(ivx,nnl(ivx)) = lenbar
+c
+c Use a one-line function to set nnodur. It gives inverse of ifnodur.
+c
+ nnodur = index('62514x0x37',
+ * chax(48+int(log(.1+lenbar)/.69315)))-1
+ fulbrp = .false.
+ end if
+ rest(ivx,nnl(ivx)) = charq.eq.'r'
+c
+c If inside forced beam, check if note is beamable
+c
+ if (fbon) then
+ if (nodur(ivx,nnl(ivx)) .lt. 16) go to 120
+ if (nnl(ivx) .gt. 1) then
+ if (nodur(ivx,nnl(ivx)-1) .eq. 0) go to 120
+ end if
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Unbeamable thing in forced beam!')
+ call stop1()
+ end if
+120 continue
+c
+c Get number of prior bars for later check on whether note spans bar line
+c
+ nbb4 = itsofar(ivx)/lenbar
+ itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
+ if (mod(itsofar(ivx),lenbar) .eq. 0) then
+ nbars = nbars+1
+ if (shifton) barend = .true.
+c
+c Will check barend when 1st note of next bar is entered.
+c
+ if (nbars .gt. 15) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Cannot have more than 15 bars in an input block!')
+ call stop1()
+ end if
+ nib(ivx,nbars) = nnl(ivx)
+ if (firstline .and. lenbar.ne.lenbr1) then
+c
+c Just finished the pickup bar for this voice.
+c
+ if (itsofar(ivx) .ne. lenbr0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Pickup bar length disagrees with mtrnum0!')
+ call stop1()
+ end if
+ lenbar = lenbr1
+ itsofar(ivx) = 0
+ end if
+ else if (barend) then
+ if (shifton) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Bar ended with user-defined shift still on!')
+ call stop1()
+ end if
+ barend = .false.
+ else if (itsofar(ivx)/lenbar .gt. nbb4) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'This note spans a bar line!')
+ call stop1()
+ end if
+ if (idotform.eq.1 .or. idotform.eq.3) then
+ call g1etchar(lineq,iccount,charq)
+ if (index('abcedfgr',charq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected note name or "r" here!')
+ call stop1()
+ end if
+ idotform = idotform+1
+ numnum = 1
+ go to 28
+ end if
+c
+c End of sub block for note-rest
+c
+ else if (charq .eq. 'z') then
+ call g1etchar(lineq,iccount,charq)
+ if (index('abcdefg',charq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected chord note name here!')
+ call stop1()
+ end if
+25 call g1etchar(lineq,iccount,durq)
+c if (index('dre12345678',durq) .gt. 0) then
+ if (index('dre12345678c',durq) .gt. 0) then
+ go to 25
+ else if (index('fsn',durq) .gt. 0) then
+c
+c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so
+c MUST come right after "f,s,n"
+c
+ if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
+ go to 25
+ else if (durq .eq. 'A') then
+ if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Must have "f,s,n" before "A" in chord note!')
+ call stop1()
+ end if
+ go to 25
+ else if (index('<>',durq) .gt. 0) then
+ if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then
+c if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Must have "f,s,n,A" before "<" or ">"!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,durq)
+ if (index('1234567890.',durq) .eq. 0) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Expected a number to start here for accidental shift!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ iccount = iccount-1
+ go to 25
+ else if (index('+-',durq) .gt. 0) then
+ if (index('1234567890.',lineq(iccount+1:iccount+1)) .eq. 0)
+ * go to 25
+c
+c Number or '.' (durq) follows +/- . Get it.
+c
+ call g1etchar(lineq,iccount,durq)
+ if (durq .eq. '.' .and. index('1234567890',
+ * lineq(iccount+1:iccount+1)) .eq. 0) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * '"." here must be followed by a digit!')
+ call stop1()
+ else if (index('sfndA',lineq(iccount-2:iccount-2)).eq.0) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Number after +/- must follow "d,s,f,n,A"!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ if (index('+-',durq) .eq. 0) then
+ iccount = iccount-1
+ go to 25
+ end if
+c
+c 2nd +/-
+c
+ call g1etchar(lineq,iccount,durq)
+ if (durq .eq. '.') call g1etchar(lineq,iccount,durq)
+ if (index('1234567890',durq) .eq. 0) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Expected a number here!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ iccount = iccount-1
+ go to 25
+ else if (durq .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character in chord note!')
+ call stop1()
+ end if
+ else if (charq .eq. 'G') then
+ ngr = 1
+9 call g1etchar(lineq,iccount,charq)
+ if (index('123456789',charq) .gt. 0) then
+ call readnum(lineq,iccount,durq,fnum)
+ ngr = nint(fnum)
+ iccount = iccount-1
+ go to 9
+ else if (index('AWulxs',charq) .gt. 0) then
+ go to 9
+ else if (charq .eq. 'm') then
+ call g1etchar(lineq,iccount,charq)
+ if (index('01234',charq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'A digit less than 5 must follow "m" in a grace note!')
+ call stop1()
+ end if
+ go to 9
+ else if (charq .eq. 'X') then
+c
+c Space before main note
+c
+ call g1etchar(lineq,iccount,charq)
+ if (index('0123456789.',charq) .gt. 0) then
+ call readnum(lineq,iccount,durq,fnum)
+ iccount = iccount-1
+ go to 9
+ else
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'A number must follow "X" in a grace note!')
+ call stop1()
+ end if
+ end if
+c
+c At this point, charq is first note name in rest (grace?)
+c
+ do 19 igr = 1 , ngr
+ numnum = 0
+ if (igr .gt. 1) then
+55 call g1etchar(lineq,iccount,charq)
+ if (charq .eq. ' ') go to 55
+ end if
+ if (index('abcdefg',charq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'In grace, expected "a"-"g"!')
+ call stop1()
+ end if
+18 call g1etchar(lineq,iccount,charq)
+ if (charq .ne. ' ') then
+ if (index('1234567',charq) .gt. 0) then
+ if (numnum .eq. 1) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Only one of "+-1234567" allowed here in grace!')
+ call stop1()
+ end if
+ numnum = 1
+ go to 18
+c else if (index('nfs',charq) .gt. 0) then
+ else if (index('+-nfs',charq) .gt. 0) then
+ go to 18
+ end if
+c
+c Digits are possible octave numbers
+c
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character after note name in grace!')
+ call stop1()
+ end if
+19 continue
+ else if (charq .eq. chax(92)) then
+ call chklit(lineq,iccount,literr)
+ if (literr .gt. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * literq(literr))
+ call stop1()
+ end if
+ else if (charq .eq. chax(34)) then
+c
+c pmx lyric
+c
+ call chkpmxlyr(lineq,iccount,lyrerr)
+ if (lyrerr .gt. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * lyrerq(lyrerr))
+ call stop1()
+ end if
+ else if (charq .eq. 'o') then
+c
+c Ornament on non-xtup note. "o" symbol must come AFTER the affected note
+c
+ if (nnl(ivx) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * '"o" must be in same input block, after affected note!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,dumq)
+c if (index('(stmgx+Tupf._)e:>^bc',dumq) .eq. 0 ) then
+ if (index('(stmgx+Tupf._)e:>^bcCG',dumq) .eq. 0 ) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal ornament!')
+ call stop1()
+ end if
+ if (dumq .eq. ':') then
+ call g1etchar(lineq,iccount,dumq)
+ if (dumq .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected blank after "o:"!')
+ call stop1()
+ else if (.not.ornrpt) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Turned off repeated ornaments before they were on!')
+ call stop1()
+ end if
+ ornrpt = .false.
+ else if (dumq .eq. 'g') then
+ if (issegno) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Sorry, only one "segno" per input block!')
+ call stop1()
+ else if (ivx .ne. 1) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'segno can only be in voice 1!')
+ call stop1()
+ end if
+ issegno = .true.
+12 call g1etchar(lineq,iccount,dumq)
+ if (dumq.eq.'-' .or.
+ * (ichar(dumq).ge.48.and.ichar(dumq).le.58)) go to 12
+ if (dumq .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character in segno ornament symbol!')
+ call stop1()
+ end if
+ else if (dumq .eq. 'T') then
+c
+c Trill. may be followed by 't' and/or number. read 'til blank
+c
+22 call g1etchar(lineq,iccount,dumq)
+ if (dumq .eq. ':') then
+ if (lineq(iccount+1:iccount+1) .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected blank after ":"!')
+ call stop1()
+ end if
+ go to 32
+ else if (dumq .ne. ' ') then
+ go to 22
+ end if
+ else if (dumq .eq. 'f') then
+ call g1etchar(lineq,iccount,dumq)
+ if (index(' d+-:',dumq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character after "f" in fermata ornament symbol!')
+ call stop1()
+ end if
+ if (dumq .eq. 'd') call g1etchar(lineq,iccount,dumq)
+ if (dumq .eq. ':') go to 32
+ else if (dumq .eq. 'e') then
+ call g1etchar(lineq,iccount,dumq)
+ if (index('sfn?',dumq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character after "e" in edit. accid. symbol!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,dumq)
+ if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq)
+ else
+ call g1etchar(lineq,iccount,dumq)
+ end if
+ if (index('+- :',dumq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character in ornament symbol!')
+ call stop1()
+ end if
+ if (index('+-',dumq) .gt. 0) then
+ if (index('0123456789',lineq(iccount+1:iccount+1)).eq.0) then
+ call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
+ * 'There should be an integer here!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ if (durq .eq. ':') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Cannot shift AND repeat an ornament!')
+ call stop1()
+ end if
+c
+c 12/7/03 Allow horizontal shift on any ornament, not just breath and caes.
+c
+ if (index('+-',durq) .gt. 0) then
+ if (index('.0123456789',lineq(iccount+1:iccount+1))
+ * .eq. 0) then
+ call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
+ * 'There should be a number here!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ end if
+ end if
+32 continue
+ if (dumq .eq. ':') then
+ if (lineq(iccount+1:iccount+1) .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * '":" must be followed by blank in "o: "!')
+ call stop1()
+ else if (ornrpt) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Turned on repeated ornaments but already on!')
+ call stop1()
+ end if
+ ornrpt = .true.
+ end if
+ else if (index('st(){}',charq) .gt. 0) then
+ numint = 0
+ iposn = 0
+8 call g1etchar(lineq,iccount,dumq)
+ iposn = iposn+1
+ if (charq.eq.'t' .and. dumq.eq.'t') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Cannot use "t" as an option on a tie!')
+ call stop1()
+ end if
+ if (index('udltb+-fnhHpsv ',dumq) .eq. 0) then
+c
+c Check for explicit ID code.
+c
+ ic = ichar(dumq)
+ if (ic.lt.48 .or. (ic.gt.57.and.ic.lt.65) .or.
+ * ic.gt.90) then
+c
+c Not 0-9 or A-Z, so exit
+c
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character in slur symbol!')
+ call stop1()
+ else
+c
+c It is a possible ID code. Right place?
+c
+ if (iposn .ne. 1) then
+c
+c Slur ID is not 2nd!
+c
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Slur ID must be second character in slur symbol!')
+ call stop1()
+ else if (charq.eq.'t' .and. fontslur) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Slur ID not allowed on non-postscript tie!')
+ call stop1()
+ else if (lineq(iccount+1:iccount+1).eq.'x') then
+ iccount = iccount+1
+ end if
+ end if
+c
+c Slur ID is OK. Note it cannot be "H" at this point..
+c
+ go to 8
+ else if (dumq .eq. 'H') then
+ if (iposn .eq. 1) go to 8
+c
+c "H" is NOT an ID code.
+c
+ if (.not.fontslur .and. charq.eq.'t') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Cannot reshape postscript ties this way!')
+ call stop1()
+ end if
+ if (lineq(iccount+1:iccount+1) .eq. 'H') then
+ iccount=iccount+1
+ iposn = iposn+1
+ end if
+ go to 8
+ else if (index('fh',dumq).gt.0 .and. .not.fontslur
+ * .and. charq.eq.'t') then
+c
+c 3/9/03 Can't reshape postscript tie.
+c
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Cannot reshape postscript ties this way!')
+ call stop1()
+ else if (dumq .eq. 'p') then
+c
+c local change in postscript slur/tie adjustment default
+c
+ if (fontslur) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Must use postscript slurs ("Ap") to use this option!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,dumq)
+ if (index('+-',dumq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected "+" or "-" here!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,dumq)
+ if (index('st',dumq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expected "s" or "t" here!')
+ call stop1()
+ end if
+ iposn = iposn+2
+ go to 8
+ end if
+ if (index('udltbfnh',dumq) .gt. 0) then
+ go to 8
+ else if (index('+-',dumq) .gt. 0) then
+ numint = numint+1
+ if (fontslur .and. charq.eq.'t') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * '"+|-" for slur height only allowed in "s"-slurs!')
+ call stop1()
+ end if
+ iccount = iccount+1
+ call readnum(lineq,iccount,durq,fnum)
+ if (numint .eq. 1) then
+ if (nint(fnum) .gt. 30) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Magnitude of slur height adjustment cannot exceed 30!')
+ call stop1()
+ end if
+ else if (numint .eq. 2) then
+ if (abs(fnum) .gt. 6.3) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Slur horiz shift must be in range (-6.3,6.3)!')
+ call stop1()
+ end if
+ else
+c
+c Third signed integer, must be a midslur or curve spec.
+c
+ if (abs(fnum).gt.31) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Slur midheight must be in the range (-31,31)!')
+ call stop1()
+ end if
+ if (durq .eq. ':') then
+c
+c Expecting curve parameters. Get two numbers
+c
+ do 41 i = 1 , 2
+ iccount = iccount+1
+ fnum = ichar(lineq(iccount:iccount))-48
+ if (abs(fnum-3.5) .gt. 3.6) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Slur curve parameter must be in range (0,7)!')
+ call stop1()
+ end if
+41 continue
+ iccount = iccount+1
+ end if
+ end if
+ iccount = iccount-1
+ go to 8
+ else if (dumq .eq. 's') then
+c
+c What follows should be one or two signed numbers for adjustment of line break
+c slur, end of 1st segment or start of second.
+c
+ if (fontslur) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'May not use linebreak slur options with font-based slurs!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,dumq)
+ if (index('+-',dumq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'This character must be "+" or "-"!')
+ call stop1()
+ end if
+ iccount = iccount+1
+ call readnum(lineq,iccount,dumq,fnum)
+ if (nint(fnum) .gt. 30) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Magnitude of slur height adjustment cannot exceed 30!')
+ call stop1()
+ end if
+ if (index('+-',dumq) .gt. 0) then
+ iccount = iccount+1
+ call readnum(lineq,iccount,dumq,fnum)
+ if (abs(fnum) .gt. 6.3) then
+ call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
+ * 'Slur horiz shift must be in range (-6.3,6.3)!')
+ call stop1()
+ end if
+ end if
+ iccount = iccount-1
+ go to 8
+ else if (dumq .eq. 'H' .and. iposn.gt.1) then
+ if (lineq(iccount+1:iccount+1) .eq. 'H') iccount=iccount+1
+ go to 8
+ end if
+ else if (charq .eq. '?') then
+ call getchar(lineq,iccount,durq)
+ if (durq .eq. ' ') then
+ iccount = iccount-1
+ else
+ if (durq .ne. '-') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expecting "-"!')
+ call stop1()
+ end if
+ call getchar(lineq,iccount,durq)
+ if (index('0123456789.',durq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Expecting number!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,durq,fnum)
+ iccount = iccount-1
+ end if
+ else if ((ichar(charq).ge.48.and.ichar(charq).le.57) .or.
+ * index('#-nx_',charq) .gt. 0) then
+c
+c We have a figure. Must come AFTER the note it goes under
+c
+ if (itsofar(ivx).eq.0 .and.
+ * (.not.firstline.or.lenbr0.eq.0.or.lenbar.eq.lenbr0)) then
+c
+c Figure before first note in block
+c
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Cannot put figure before first note in block!')
+ call stop1()
+ end if
+ if (charq.eq.'x') then
+ indxb = index(lineq(iccount:128),' ')
+ if (indxb .lt. 5) then
+ call errmsg(lineq,iccount+indxb-1,ibarcnt-ibaroff+nbars+1,
+ * 'Cannot have a blank here in floating figure!')
+ call stop1()
+ end if
+ end if
+ if (usefig) ifig = 1
+5 call g1etchar(lineq,iccount,charq)
+ if (index(' 0123456789#-nx_.:+sv',charq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character in figure!')
+ call stop1()
+ else if (charq .eq. '+') then
+c
+c vertical offset, must be integer, then blank
+c
+ call g1etchar(lineq,iccount,charq)
+ if (index('123456789',charq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Integer for vertical offset expected here!')
+ call stop1()
+ end if
+ call readnum(lineq,iccount,charq,fnum)
+ if (charq .ne. ' ') then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Vertical offset must terminate figure!')
+ call stop1()
+ end if
+ iccount = iccount-1
+ go to 5
+ else if (charq .eq. 's') then
+ isligfont = .true.
+ end if
+ if (charq .ne. ' ') go to 5
+ else if (charq .eq. '[') then
+ if (fbon) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Started forced beam while another was open!')
+ call stop1()
+ end if
+ fbon = .true.
+17 call g1etchar(lineq,iccount,charq)
+ if (index('uljhf:',charq) .gt. 0) then
+ go to 17
+ else if (index('+-',charq) .gt. 0) then
+ iccount = iccount+1
+ call readnum(lineq,iccount,durq,fnum)
+ iccount = iccount-1
+ go to 17
+ else if (charq .eq. 'm') then
+c
+c Forced multiplicity, next char should be 1-4
+c
+ call g1etchar(lineq,iccount,charq)
+ if (index('1234',charq) .eq. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Forced multiplicity for a beam must be 1, 2, 3, or 4!')
+ call stop1()
+ end if
+ go to 17
+ else if (charq .ne. ' ') then
+ if (index('0123456789',charq) .gt. 0) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'After "[", digits must now be preceeded by "+" or "-"!')
+ print*,'You will have to edit older sources to meet this rqmt,'
+ print*,'but it was needed to allow 2-digit height adjustments.'
+ print*,'Sorry for the inconvenience. --The Management'
+ else
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Illegal character after [!')
+ end if
+ call stop1()
+ end if
+ else if (charq .eq. ']') then
+ if (.not.fbon) then
+ call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
+ * 'Forced beam stop with no corresponding start!')
+ call stop1()
+ end if
+ call g1etchar(lineq,iccount,charq)
+ if (charq .eq. '-') then
+ if (lineq(iccount+1:iccount+2) .ne. '[ ') then
+ call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
+ * 'Only sequence allowed here is "[ "!')
+ call stop1()
+ else
+ iccount = iccount+2
+ end if
+ else if (charq .eq. '[') then
+ if (lineq(iccount+1:iccount+1) .ne. ' ') then
+ call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
+ * 'This character must be a blank!')
+ call stop1()
+ end if
+ else
+c
+c Forced beam is really ending
+c
+ fbon = .false.
+ if (charq .eq. 'j') then
+ if (lineq(iccount+1:iccount+1) .ne. ' ') then
+ call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
@@ Diff output truncated at 1234567 characters. @@
More information about the tex-live-commits
mailing list.