diff options
author | Peter Breitenlohner <peb@mppmu.mpg.de> | 2012-05-20 10:47:27 +0000 |
---|---|---|
committer | Peter Breitenlohner <peb@mppmu.mpg.de> | 2012-05-20 10:47:27 +0000 |
commit | 4a0b3e0795ff26c3ad05eebcd302499751a85533 (patch) | |
tree | ae21b2d7e0f1b5cb5577cd26d9013f14ca630e22 /Build/source/utils/pmx/pmx-2.6.18 | |
parent | 2ca45d9d72fa0af0158e732449d29281505da678 (diff) |
more pmx 2.6.18
do handle pmx2pdf.lua here because we need a symlink in bindir
git-svn-id: svn://tug.org/texlive/trunk@26502 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build/source/utils/pmx/pmx-2.6.18')
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.18/arith.h | 0 | ||||
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.18/config.h.in | 90 | ||||
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile | 61 | ||||
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice | 23 | ||||
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.18/libf2c/README | 329 | ||||
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c | 225 | ||||
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h | 3 | ||||
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h | 5 | ||||
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c | 3 | ||||
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.18/pmx2617.f | 23597 | ||||
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.18/scor2prt.f | 1619 |
11 files changed, 11 insertions, 25944 deletions
diff --git a/Build/source/utils/pmx/pmx-2.6.18/arith.h b/Build/source/utils/pmx/pmx-2.6.18/arith.h deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/arith.h +++ /dev/null diff --git a/Build/source/utils/pmx/pmx-2.6.18/config.h.in b/Build/source/utils/pmx/pmx-2.6.18/config.h.in deleted file mode 100644 index 5706e9a0864..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/config.h.in +++ /dev/null @@ -1,90 +0,0 @@ -/* config.h.in. Generated from configure.ac by autoheader. */ - -/* Define to 1 if you have the `atexit' function. */ -#undef HAVE_ATEXIT - -/* Define to 1 if you have the <fenv.h> header file. */ -#undef HAVE_FENV_H - -/* Define to 1 if you have the `floor' function. */ -#undef HAVE_FLOOR - -/* Define to 1 if you have the <inttypes.h> header file. */ -#undef HAVE_INTTYPES_H - -/* Define to 1 if you have the `m' library (-lm). */ -#undef HAVE_LIBM - -/* Define to 1 if your system has a GNU libc compatible `malloc' function, and - to 0 otherwise. */ -#undef HAVE_MALLOC - -/* Define to 1 if you have the <memory.h> header file. */ -#undef HAVE_MEMORY_H - -/* Define to 1 if you have the `memset' function. */ -#undef HAVE_MEMSET - -/* Define to 1 if you have the `pow' function. */ -#undef HAVE_POW - -/* Define to 1 if your system has a GNU libc compatible `realloc' function, - and to 0 otherwise. */ -#undef HAVE_REALLOC - -/* Define to 1 if you have the `sqrt' function. */ -#undef HAVE_SQRT - -/* Define to 1 if you have the <stdint.h> header file. */ -#undef HAVE_STDINT_H - -/* Define to 1 if you have the <stdlib.h> header file. */ -#undef HAVE_STDLIB_H - -/* Define to 1 if you have the <strings.h> header file. */ -#undef HAVE_STRINGS_H - -/* Define to 1 if you have the <string.h> header file. */ -#undef HAVE_STRING_H - -/* Define to 1 if you have the <sys/stat.h> header file. */ -#undef HAVE_SYS_STAT_H - -/* Define to 1 if you have the <sys/types.h> header file. */ -#undef HAVE_SYS_TYPES_H - -/* Define to 1 if you have the <unistd.h> header file. */ -#undef HAVE_UNISTD_H - -/* Name of package */ -#undef PACKAGE - -/* Define to the address where bug reports for this package should be sent. */ -#undef PACKAGE_BUGREPORT - -/* Define to the full name of this package. */ -#undef PACKAGE_NAME - -/* Define to the full name and version of this package. */ -#undef PACKAGE_STRING - -/* Define to the one symbol short name of this package. */ -#undef PACKAGE_TARNAME - -/* Define to the version of this package. */ -#undef PACKAGE_VERSION - -/* Define to 1 if you have the ANSI C header files. */ -#undef STDC_HEADERS - -/* Version number of package */ -#undef VERSION - -/* Define to rpl_malloc if the replacement function should be used. */ -#undef malloc - -/* Define to rpl_realloc if the replacement function should be used. */ -#undef realloc - -/* Define to `unsigned int' if <sys/types.h> does not define. */ -#undef size_t diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile b/Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile deleted file mode 100644 index 528a7418bbb..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile +++ /dev/null @@ -1,61 +0,0 @@ -CFLAGS = -Wall -W -pedantic -O2 -DNON_UNIX_STDIO -fPIC - -MISC = f77vers.o i77vers.o main.o s_rnge.o abort_.o exit_.o getarg_.o iargc_.o\ - getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o\ - derf_.o derfc_.o erf_.o erfc_.o sig_die.o uninit.o -POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o -CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o -DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o -REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\ - r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\ - r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\ - r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o -DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\ - d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\ - d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\ - d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\ - d_sqrt.o d_tan.o d_tanh.o -INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o\ - lbitbits.o lbitshft.o -HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o -CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o -EFL = ef1asc_.o ef1cmc_.o -CHAR = f77_aloc.o s_cat.o s_cmp.o s_copy.o -I77 = backspac.o close.o dfe.o dolio.o due.o endfile.o err.o\ - fmt.o fmtlib.o ftell_.o iio.o ilnw.o inquire.o lread.o lwrite.o\ - open.o rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o\ - typesize.o uio.o util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o -QINT = pow_qq.o qbitbits.o qbitshft.o ftell64_.o -TIME = dtime_.o etime_.o - -OFILES = $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ - $(HALF) $(CMP) $(EFL) $(CHAR) $(I77) $(TIME) - -all: arith.h f2c.h signal1.h sysdep1.h libf2c.a - -libf2c.a: $(OFILES) - ar r libf2c.a $? - -f77vers.o: f77vers.c - -i77vers.o: i77vers.c - - -arith.h: arithchk.c - $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c -lm ||\ - $(CC) -DNO_LONG_LONG $(CFLAGS) -DNO_FPINIT arithchk.c -lm - ./a.out >arith.h - rm -f a.out arithchk.o - -clean: - rm -f libf2c.a *.o arith.h - - -EMPTY_AUTOMAKE_TARGETS = dvi pdf ps info html tags ctags install install-data install-exec uninstall install-dvi install-html install-info install-ps install-pdf installdirs check installcheck mostlyclean distclean maintainer-clean -.PHONY: $(EMPTY_AUTOMAKE_TARGETS) -$(EMPTY_AUTOMAKE_TARGETS): - -DISTFILES = -distdir: $(DISTFILES) - cp Notice Makefile README *.h *.c $(distdir) - cp f2c.h $(top_distdir) diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice b/Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice deleted file mode 100644 index 261b719bc57..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice +++ /dev/null @@ -1,23 +0,0 @@ -/**************************************************************** -Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/README b/Build/source/utils/pmx/pmx-2.6.18/libf2c/README deleted file mode 100644 index 73388d0bd4f..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/README +++ /dev/null @@ -1,329 +0,0 @@ -If your system has a double drem() function such that drem(a,b) -is the IEEE remainder function (with double a, b), then you may -wish to compile r_mod.c and d_mod.c with IEEE_drem defined. - -On machines, such as those using a DEC Alpha processor, on which -sizeof(short) == 2, sizeof(int) == sizeof(float) == 4, and -sizeof(long) == sizeof(double) == 8, it suffices to modify f2c.h by -removing the first occurrence of "long " on each line containing -"long ". On Unix systems, you can do this by issuing the commands - mv f2c.h f2c.h0 - sed 's/long int /int /' f2c.h0 >f2c.h -On such machines, one can enable INTEGER*8 by uncommenting the typedefs -of longint and ulongint in f2c.h and adjusting them, so they read - typedef long longint; - typedef unsigned long ulongint; -and by compiling libf2c with -DAllow_TYQUAD, as discussed below. - - -Most of the routines in libf2c are support routines for Fortran -intrinsic functions or for operations that f2c chooses not -to do "in line". There are a few exceptions, summarized below -- -functions and subroutines that appear to your program as ordinary -external Fortran routines. - -If you use the REAL valued functions listed below (ERF, ERFC, -DTIME, and ETIME) with "f2c -R", then you need to compile the -corresponding source files with -DREAL=float. To do this, it is -perhaps simplest to add "-DREAL=float" to CFLAGS in the makefile. - -1. CALL ABORT prints a message and causes a core dump. - -2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION - error functions (with x REAL and d DOUBLE PRECISION); - DERF must be declared DOUBLE PRECISION in your program. - Both ERF and DERF assume your C library provides the - underlying erf() function (which not all systems do). - -3. ERFC(r) and DERFC(d) are the complementary error functions: - ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d) - (except that their results may be more accurate than - explicitly evaluating the above formulae would give). - Again, ERFC and r are REAL, and DERFC and d are DOUBLE - PRECISION (and must be declared as such in your program), - and ERFC and DERFC rely on your system's erfc(). - -4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER - variable, sets s to the n-th command-line argument (or to - all blanks if there are fewer than n command-line arguments); - CALL GETARG(0,s) sets s to the name of the program (on systems - that support this feature). See IARGC below. - -5. CALL GETENV(name, value), where name and value are of type - CHARACTER, sets value to the environment value, $name, of - name (or to blanks if $name has not been set). - -6. NARGS = IARGC() sets NARGS to the number of command-line - arguments (an INTEGER value). - -7. CALL SIGNAL(n,func), where n is an INTEGER and func is an - EXTERNAL procedure, arranges for func to be invoked when n - occurs (on systems where this makes sense). - -If your compiler complains about the signal calls in main.c, s_paus.c, -and signal_.c, you may need to adjust signal1.h suitably. See the -comments in signal1.h. - -8. ETIME(ARR) and DTIME(ARR) are REAL functions that return - execution times. ARR is declared REAL ARR(2). The elapsed - user and system CPU times are stored in ARR(1) and ARR(2), - respectively. ETIME returns the total elapsed CPU time, - i.e., ARR(1) + ARR(2). DTIME returns total elapsed CPU - time since the previous call on DTIME. - -9. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes - cmd to the system's command processor (on systems where - this can be done). - -10. CALL FLUSH flushes all buffers. - -11. FTELL(i) is an INTEGER function that returns the current - offset of Fortran unit i (or -1 if unit i is not open). - -12. CALL FSEEK(i, offset, whence, *errlab) attemps to move - Fortran unit i to the specified offset: absolute offset - if whence = 0; relative to the current offset if whence = 1; - relative to the end of the file if whence = 2. It branches - to label errlab if unit i is not open or if the call - otherwise fails. - -The routines whose objects are makefile.u's $(I77) are for I/O. -The following comments apply to them. - -If your system lacks /usr/include/local.h , -then you should create an appropriate local.h in -this directory. An appropriate local.h may simply -be empty, or it may #define VAX or #define CRAY -(or whatever else you must do to make fp.h work right). -Alternatively, edit fp.h to suite your machine. - -If your system lacks /usr/include/fcntl.h , then you -should simply create an empty fcntl.h in this directory. -If your compiler then complains about creat and open not -having a prototype, compile with OPEN_DECL defined. -On many systems, open and creat are declared in fcntl.h . - -If your system's sprintf does not work the way ANSI C -specifies -- specifically, if it does not return the -number of characters transmitted -- then insert the line - -#define USE_STRLEN - -at the end of fmt.h . This is necessary with -at least some versions of Sun software. -In particular, if you get a warning about an improper -pointer/integer combination in compiling wref.c, then -you need to compile with -DUSE_STRLEN . - -If your system's fopen does not like the ANSI binary -reading and writing modes "rb" and "wb", then you should -compile open.c with NON_ANSI_RW_MODES #defined. - -If you get error messages about references to cf->_ptr -and cf->_base when compiling wrtfmt.c and wsfe.c or to -stderr->_flag when compiling err.c, then insert the line - -#define NON_UNIX_STDIO - -at the beginning of fio.h, and recompile everything (or -at least those modules that contain NON_UNIX_STDIO). - -Unformatted sequential records consist of a length of record -contents, the record contents themselves, and the length of -record contents again (for backspace). Prior to 17 Oct. 1991, -the length was of type int; now it is of type long, but you -can change it back to int by inserting - -#define UIOLEN_int - -at the beginning of fio.h. This affects only sue.c and uio.c . - -If you have a really ancient K&R C compiler that does not understand -void, add -Dvoid=int to the definition of CFLAGS in the makefile. - -On VAX, Cray, or Research Tenth-Edition Unix systems, you may -need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS -to make fp.h work correctly. Alternatively, you may need to -edit fp.h to suit your machine. - -If your compiler complains about the signal calls in main.c, s_paus.c, -and signal_.c, you may need to adjust signal1.h suitably. See the -comments in signal1.h. - -You may need to supply the following non-ANSI routines: - - fstat(int fileds, struct stat *buf) is similar -to stat(char *name, struct stat *buf), except that -the first argument, fileds, is the file descriptor -returned by open rather than the name of the file. -fstat is used in the system-dependent routine -canseek (in the libf2c source file err.c), which -is supposed to return 1 if it's possible to issue -seeks on the file in question, 0 if it's not; you may -need to suitably modify err.c . On non-UNIX systems, -you can avoid references to fstat and stat by compiling -with NON_UNIX_STDIO defined; in that case, you may need -to supply access(char *Name,0), which is supposed to -return 0 if file Name exists, nonzero otherwise. - - char * mktemp(char *buf) is supposed to replace the -6 trailing X's in buf with a unique number and then -return buf. The idea is to get a unique name for -a temporary file. - -On non-UNIX systems, you may need to change a few other, -e.g.: the form of name computed by mktemp() in endfile.c and -open.c; the use of the open(), close(), and creat() system -calls in endfile.c, err.c, open.c; and the modes in calls on -fopen() and fdopen() (and perhaps the use of fdopen() itself --- it's supposed to return a FILE* corresponding to a given -an integer file descriptor) in err.c and open.c (component ufmt -of struct unit is 1 for formatted I/O -- text mode on some systems --- and 0 for unformatted I/O -- binary mode on some systems). -Compiling with -DNON_UNIX_STDIO omits all references to creat() -and almost all references to open() and close(), the exception -being in the function f__isdev() (in open.c). - -If you wish to use translated Fortran that has funny notions -of record length for direct unformatted I/O (i.e., that assumes -RECL= values in OPEN statements are not bytes but rather counts -of some other units -- e.g., 4-character words for VMS), then you -should insert an appropriate #define for url_Adjust at the -beginning of open.c . For VMS Fortran, for example, -#define url_Adjust(x) x *= 4 -would suffice. - -By default, Fortran I/O units 5, 6, and 0 are pre-connected to -stdin, stdout, and stderr, respectively. You can change this -behavior by changing f_init() in err.c to suit your needs. -Note that f2c assumes READ(*... means READ(5... and WRITE(*... -means WRITE(6... . Moreover, an OPEN(n,... statement that does -not specify a file name (and does not specify STATUS='SCRATCH') -assumes FILE='fort.n' . You can change this by editing open.c -and endfile.c suitably. - -Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units -0, 1, ..., 99 are available, i.e., the highest allowed unit number -is MXUNIT - 1. - -Lines protected from compilation by #ifdef Allow_TYQUAD -are for a possible extension to 64-bit integers in which -integer = int = 32 bits and longint = long = 64 bits. - -The makefile does not attempt to compile pow_qq.c, qbitbits.c, -and qbitshft.c, which are meant for use with INTEGER*8. To use -INTEGER*8, you must modify f2c.h to declare longint and ulongint -appropriately; then add $(QINT) to the end of the makefile's -dependency list for libf2c.a (if makefile is a copy of makefile.u; -for the PC makefiles, add pow_qq.obj qbitbits.obj qbitshft.obj -to the library's dependency list and adjust libf2c.lbc or libf2c.sy -accordingly). Also add -DAllow_TYQUAD to the makefile's CFLAGS -assignment. To make longint and ulongint available, it may suffice -to add -DINTEGER_STAR_8 to the CFLAGS assignment. - -Following Fortran 90, s_cat.c and s_copy.c allow the target of a -(character string) assignment to be appear on its right-hand, at -the cost of some extra overhead for all run-time concatenations. -If you prefer the extra efficiency that comes with the Fortran 77 -requirement that the left-hand side of a character assignment not -be involved in the right-hand side, compile s_cat.c and s_copy.c -with -DNO_OVERWRITE . - -Extensions (Feb. 1993) to NAMELIST processing: - 1. Reading a ? instead of &name (the start of a namelist) causes -the namelist being sought to be written to stdout (unit 6); -to omit this feature, compile rsne.c with -DNo_Namelist_Questions. - 2. Reading the wrong namelist name now leads to an error message -and an attempt to skip input until the right namelist name is found; -to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip. - 3. Namelist writes now insert newlines before each variable; to omit -this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines. - 4. (Sept. 1995) When looking for the &name that starts namelist -input, lines whose first non-blank character is something other -than &, $, or ? are treated as comment lines and ignored, unless -rsne.c is compiled with -DNo_Namelist_Comments. - -Nonstandard extension (Feb. 1993) to open: for sequential files, -ACCESS='APPEND' (or access='anything else starting with "A" or "a"') -causes the file to be positioned at end-of-file, so a write will -append to the file. - -Some buggy Fortran programs use unformatted direct I/O to write -an incomplete record and later read more from that record than -they have written. For records other than the last, the unwritten -portion of the record reads as binary zeros. The last record is -a special case: attempting to read more from it than was written -gives end-of-file -- which may help one find a bug. Some other -Fortran I/O libraries treat the last record no differently than -others and thus give no help in finding the bug of reading more -than was written. If you wish to have this behavior, compile -uio.c with -DPad_UDread . - -If you want to be able to catch write failures (e.g., due to a -disk being full) with an ERR= specifier, compile dfe.c, due.c, -sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to -slower execution and more I/O, but should make ERR= work as -expected, provided fflush returns an error return when its -physical write fails. - -Carriage controls are meant to be interpreted by the UNIX col -program (or a similar program). Sometimes it's convenient to use -only ' ' as the carriage control character (normal single spacing). -If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted -external output lines will have an initial ' ' quietly omitted, -making use of the col program unnecessary with output that only -has ' ' for carriage control. - -The Fortran 77 Standard leaves it up to the implementation whether -formatted writes of floating-point numbers of absolute value < 1 have -a zero before the decimal point. By default, libI77 omits such -superfluous zeros, but you can cause them to appear by compiling -lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 . - -If your (Unix) system lacks a ranlib command, you don't need it. -Either comment out the makefile's ranlib invocation, or install -a harmless "ranlib" command somewhere in your PATH, such as the -one-line shell script - - exit 0 - -or (on some systems) - - exec /usr/bin/ar lts $1 >/dev/null - -By default, the routines that implement complex and double complex -division, c_div.c and z_div.c, call sig_die to print an error message -and exit if they see a divisor of 0, as this is sometimes helpful for -debugging. On systems with IEEE arithmetic, compiling c_div.c and -z_div.c with -DIEEE_COMPLEX_DIVIDE causes them instead to set both -the real and imaginary parts of the result to +INFINITY if the -numerator is nonzero, or to NaN if it vanishes. - -Nowadays most Unix and Linux systems have function - int ftruncate(int fildes, off_t len); -defined in system header file unistd.h that adjusts the length of file -descriptor fildes to length len. Unless endfile.c is compiled with --DNO_TRUNCATE, endfile.c #includes "unistd.h" and calls ftruncate() if -necessary to shorten files. If your system lacks ftruncate(), compile -endfile.c with -DNO_TRUNCATE to make endfile.c use the older and more -portable scheme of shortening a file by copying to a temporary file -and back again. - -The initializations for "f2c -trapuv" are done by _uninit_f2c(), -whose source is uninit.c, introduced June 2001. On IEEE-arithmetic -systems, _uninit_f2c should initialize floating-point variables to -signaling NaNs and, at its first invocation, should enable the -invalid operation exception. Alas, the rules for distinguishing -signaling from quiet NaNs were not specified in the IEEE P754 standard, -nor were the precise means of enabling and disabling IEEE-arithmetic -exceptions, and these details are thus system dependent. There are -#ifdef's in uninit.c that specify them for some popular systems. If -yours is not one of these systems, it may take some detective work to -discover the appropriate details for your system. Sometimes it helps -to look in the standard include directories for header files with -relevant-sounding names, such as ieeefp.h, nan.h, or trap.h, and -it may be simplest to run experiments to see what distinguishes a -signaling from a quiet NaN. (If x is initialized to a signaling -NaN and the invalid operation exception is masked off, as it should -be by default on IEEE-arithmetic systems, then computing, say, -y = x + 1 will yield a quiet NaN.) diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c deleted file mode 100644 index 94c93e2f2a4..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c +++ /dev/null @@ -1,225 +0,0 @@ -/**************************************************************** -Copyright (C) 1997, 1998, 2000 Lucent Technologies -All Rights Reserved - -Permission to use, copy, modify, and distribute this software and -its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the name of Lucent or any of its entities -not be used in advertising or publicity pertaining to -distribution of the software without specific, written prior -permission. - -LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, -INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. -IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY -SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER -IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, -ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF -THIS SOFTWARE. -****************************************************************/ - -/* Try to deduce arith.h from arithmetic properties. */ - -#include <stdio.h> -#include <math.h> -#include <errno.h> - -#ifdef NO_FPINIT -#define fpinit_ASL() -#else -#ifndef KR_headers -extern -#ifdef __cplusplus - "C" -#endif - void fpinit_ASL(void); -#endif /*KR_headers*/ -#endif /*NO_FPINIT*/ - - static int dalign; - typedef struct -Akind { - char *name; - int kind; - } Akind; - - static Akind -IEEE_8087 = { "IEEE_8087", 1 }, -IEEE_MC68k = { "IEEE_MC68k", 2 }, -IBM = { "IBM", 3 }, -VAX = { "VAX", 4 }, -CRAY = { "CRAY", 5}; - - static double t_nan; - - static Akind * -Lcheck() -{ - union { - double d; - long L[2]; - } u; - struct { - double d; - long L; - } x[2]; - - if (sizeof(x) > 2*(sizeof(double) + sizeof(long))) - dalign = 1; - u.L[0] = u.L[1] = 0; - u.d = 1e13; - if (u.L[0] == 1117925532 && u.L[1] == -448790528) - return &IEEE_MC68k; - if (u.L[1] == 1117925532 && u.L[0] == -448790528) - return &IEEE_8087; - if (u.L[0] == -2065213935 && u.L[1] == 10752) - return &VAX; - if (u.L[0] == 1267827943 && u.L[1] == 704643072) - return &IBM; - return 0; - } - - static Akind * -icheck() -{ - union { - double d; - int L[2]; - } u; - struct { - double d; - int L; - } x[2]; - - if (sizeof(x) > 2*(sizeof(double) + sizeof(int))) - dalign = 1; - u.L[0] = u.L[1] = 0; - u.d = 1e13; - if (u.L[0] == 1117925532 && u.L[1] == -448790528) - return &IEEE_MC68k; - if (u.L[1] == 1117925532 && u.L[0] == -448790528) - return &IEEE_8087; - if (u.L[0] == -2065213935 && u.L[1] == 10752) - return &VAX; - if (u.L[0] == 1267827943 && u.L[1] == 704643072) - return &IBM; - return 0; - } - -char *emptyfmt = ""; /* avoid possible warning message with printf("") */ - - static Akind * -ccheck() -{ - union { - double d; - long L; - } u; - long Cray1; - - /* Cray1 = 4617762693716115456 -- without overflow on non-Crays */ - Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762; - if (printf(emptyfmt, Cray1) >= 0) - Cray1 = 1000000*Cray1 + 693716; - if (printf(emptyfmt, Cray1) >= 0) - Cray1 = 1000000*Cray1 + 115456; - u.d = 1e13; - if (u.L == Cray1) - return &CRAY; - return 0; - } - - static int -fzcheck() -{ - double a, b; - int i; - - a = 1.; - b = .1; - for(i = 155;; b *= b, i >>= 1) { - if (i & 1) { - a *= b; - if (i == 1) - break; - } - } - b = a * a; - return b == 0.; - } - - static int -need_nancheck() -{ - double t; - - errno = 0; - t = log(t_nan); - if (errno == 0) - return 1; - errno = 0; - t = sqrt(t_nan); - return errno == 0; - } - -main() -{ - FILE *f; - Akind *a = 0; - int Ldef = 0; - - fpinit_ASL(); -#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */ - f = fopen("arith.h", "w"); - if (!f) { - printf("Cannot open arith.h\n"); - return 1; - } -#else - f = stdout; -#endif - - if (sizeof(double) == 2*sizeof(long)) - a = Lcheck(); - else if (sizeof(double) == 2*sizeof(int)) { - Ldef = 1; - a = icheck(); - } - else if (sizeof(double) == sizeof(long)) - a = ccheck(); - if (a) { - fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n", - a->name, a->kind); - if (Ldef) - fprintf(f, "#define Long int\n#define Intcast (int)(long)\n"); - if (dalign) - fprintf(f, "#define Double_Align\n"); - if (sizeof(char*) == 8) - fprintf(f, "#define X64_bit_pointers\n"); -#ifndef NO_LONG_LONG - if (sizeof(long long) < 8) -#endif - fprintf(f, "#define NO_LONG_LONG\n"); - if (a->kind <= 2) { - if (fzcheck()) - fprintf(f, "#define Sudden_Underflow\n"); - t_nan = -a->kind; - if (need_nancheck()) - fprintf(f, "#define NANCHECK\n"); - } - return 0; - } - fprintf(f, "/* Unknown arithmetic */\n"); - return 1; - } - -#ifdef __sun -#ifdef __i386 -/* kludge for Intel Solaris */ -void fpsetprec(int x) { } -#endif -#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h b/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h index b94ee7c8e12..a91de9bf804 100644 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h @@ -13,6 +13,9 @@ typedef char *address; typedef short int shortint; typedef float real; typedef double doublereal; +#ifdef WIN32 +#define _COMPLEX_DEFINED 1 +#endif typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; typedef long int logical; diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h index 3d168bfcd1a..b16957a8fae 100644 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h @@ -1,7 +1,12 @@ #ifndef SYSDEP_H_INCLUDED #include "sysdep1.h" #endif +#include <sys/types.h> /* for off_t */ #include "stdio.h" +#ifdef WIN32 +extern int w32getc(FILE *f); +#define getc w32getc +#endif #include "errno.h" #ifndef NULL /* ANSI C */ diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c index 6e3def121df..49f739a3d7d 100644 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c @@ -30,6 +30,9 @@ extern integer f_clos(cllist*); #ifdef NON_ANSI_RW_MODES char *f__r_mode[2] = {"r", "r"}; char *f__w_mode[4] = {"w", "w", "r+w", "r+w"}; +#elif defined(WIN32) +char *f__r_mode[2] = {"rb", "rb"}; +char *f__w_mode[4] = {"wb", "wb", "rb+", "rb+"}; #else char *f__r_mode[2] = {"rb", "r"}; char *f__w_mode[4] = {"wb", "w", "r+b", "r+"}; diff --git a/Build/source/utils/pmx/pmx-2.6.18/pmx2617.f b/Build/source/utils/pmx/pmx-2.6.18/pmx2617.f deleted file mode 100644 index 09b5ec6e0dc..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/pmx2617.f +++ /dev/null @@ -1,23597 +0,0 @@ - program pmxab -c -c This program, PMX, developed by Don Simons -c (dsimons@roadrunner.com), is a preprocessor for MusiXTeX. In concert with -c MusiXTeX and TeX, its purpose is to allow the user to create high-quality -c typeset musical scores by including a sequence of PMX commands in an ASCII -c input file. -c -c This program is free software: you can redistribute it and/or modify -c it under the terms of the GNU General Public License as published by -c the Free Software Foundation, either version 3 of the License, or -c (at your option) any later version. -c -c This program is distributed in the hope that it will be useful, -c but WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with this program. If not, see <http://www.gnu.org/licenses/>. -c -c - character*9 date - character*5 version,versionc - common /comver/ versionc -c -c To compile with gfortran: -c 1. Merge all files using copy *.for epmx[nnnn].for -c 2. Search and replace all character*65536 with character*131072 -c 3. Comment/uncomment getarg lines -c 4. gfortran -O pmx[nnnn].for -o pmxab.exe -c -c To do -c Correct Rainer's email address in manual -c Linesplit (\\) in h -c Tt at start of a movement. -c Toggle midi on or off; allow midi only. -c Page number printed on 1st page even if 1 system. -c Still need inserted space for chordal accidentals -c Voicewise transposition. -c better segno -c coda -c duevolte -c Fix xtup bracket direction in 2-line staves?? (maybe leave as is) -c Sticky ornaments with shifts. -c Deal with Werner's vertical spacing thing associated with title. -c Multiple ties in midi -c Werner's missing c in MIDI due to start/stop ties on same note. -c Beams with single 64ths -c 128ths and/or dotted 64ths -c Close out MIDI with integral # of beats? -c Increase ast dimensions or redo logic. -c Does slur direction get set for user-defined single-note stem dir'ns? -c Transpose by sections. -c Optimization loop over sections only -c Command-line option to read nbarss in. Write out nbarss when optimizing. -c (or just read from .plg?) -c Beams over bar lines. -c 2-digit figures -c A real coule (slanted line between notes in a chord) -c Dotted slurs for grace notes. -c Undotted chord notes with dotted main note. -c Forced line break without line number -c Fix dot moving when 2nds in chord get flipped -c To do: increase length on notexq in dodyn -c 2.617 -c In g1etnote, change if-check for note to use index(...) instead -c of ichar(charq) since it was messing up gfortran optimizer -c After pmxa, search for and remove penultimate line <blank><blank>/ -c because it was screwing up linux-compiled versions -c Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...) -c 2.616 (111110) -c Allow hairpins to span multiple notes groups (gulps). -c 2.615+ (110810) -c Fix midi when some instruments are transposed, by subtracting -c iTransAmt(instno(iv)) from pitch values sent to via addmidi in -c make2bar.for (for main notes) and docrd (for chord notes) -c 2.615 (110725) -c Fig bug with size-setting (in topfile) when instrument has >1 staves -c 2.615 (110724) -c Make AS[0|-|s|t]... really set sizes -c 2.614 -c Mod notex.for to fix Terry's bug with raised dotted rests (caused -c by double-hboxing). -c 2.613 -c Bugfix: In pmxa, change "do while" limit to keep from overwriting instno. -c 2.612 -c Enhance AS to allow s or t for smallsize or tinysize -c 2.611 -c Error trap for "D" before any notes in a block. -c 2.610 -c Instrument-wise key changes and transposition (incomplete) -c 2.603 -c 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors -c following reading in an include file. -c 101121 Added some error messages in g1etset.for setup data -c 2.602 -c Correct slur indexing in linebreakslurs. -c Account for comment lines in line count for error messages -c 2.601 -c Bug fix: allow 24 slurs with graces -c 2.60 Changes made make it really big -c increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o -c major reprogramming, and 16 may also be a problem (icmm) -c nm=24 (voices) done -c 24 slurs done -c 24 simultaneous beams (Replace index 24 by 0, so get 0-23) -c bufq*131072 (gfortran only) -c getarg syntax (gfortran only) -c 2.523+ -c Fix voice numbering for normal dynamics and text dynamics -c 2.523 -c Version of bigpmx first posted to Hiroaki's web site. -c 2.522 -c 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it. -c With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices. -c 5/13/10 Fix log2 function -c 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length. -c 2.521+ -c 091025 Enable dotting 2nd part of linebreak slur or tie. -c To adjust barno height due to linebreak slur, use \bnrs instead of -c explicitly redefining \raisebarno (pmxb) -c 2.521 -c Bugfix -c 2.520 -c 090519 Enable ligfonts (special figured bass characters) -c 2.519 -c Fix another bug which kept \sk from being output so misaligned some notes. -c 2.518 -c Fix bugs: referencing fig data, char declaration for member of -c common/comfig/ -c 2.517 -c Allow figures in voice 1 + any one other. -c 2.516 -c Allow figures in voice #2 -c 2.515+ to do: Change manual and activate rule against clef change in voice #2. -c 2.515 -c 071222 Changes in getnote to allow auto forced beams to start anywhere. -c 071206 In make2bar, shift fermataup7 to left over centered pause. -c 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line -c staff (it was screwing up vertical justification). -c n34 for tweaks to midi durations of quarter note septuplets. -c To do: In ref250.tex, the tables where 's,t,)' is explained, the line -c [+,- i] ... Vertical adjustment of the start of second segment -c should it be replaced by -c [s +,- i] ... Vertical adjustment of the start of second segment -c 2.514 -c Changes in make2bar to get horizontal spacing right when normal grace -c follows after grace -c Changes in dograce to get octaves right for any material entered inside -c \gaft, which shields transpose register changes from the outside world. -c 2.513 -c In make1bar, near end, for forced beams starting with a rest, copy hgt and -c slope tweaks to ALL notes after first, not just the second one, so if -c there's more than one rest at start the tweaks are still observed. -c In beamid and beamend, add stand-alone triply-flagged notes for xtups. -c 2.512 -c Near end of pmxb, fix error trap to allow redundant 'RD' -c Enable multiplicity down-up '][' within xtup. -c 2.511 -c Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by -c adjusteskz as in bar 7 of barsant. -c 2.510a -c Test: remove restriction on tempo changes in MIDI macros -c Send to CM for beta testing. -c 2.509+ -c To do: Correct manual on AS. "-" is for smaller staves. -c 2.510 -c Forgot to declare litq, voltxtq as character in subroutine getgrace -c 2.509 -c Corrected small bug in arpeggio shifting (ivx <= iv in call putarp) -c 2.508 -c Allow graces in xtups. New subroutine getgrace. -c 2.507 -c To do: Raise/lower figures. -c To do: Add 24, 29 to list of musicsizes in manual -c New sub adjusteskz to account for ask's when computing lengths of -c brackets for unbeamed xtups, slopes and horizontal posn's of number -c Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags -c Add look-left option for keyboard rests, "L" in rest command, set iornq(30) -c 2.506 -c Fix bug with AK, when simultaneous rests have same duration, use defaults. -c 2.505 -c Keyboard rests AK -c 2.504 -c Space after normal grace: option X[n] -c Fixed og when nv .ne. noinst, by using sepsymq instead of '&' -c (To do) length of xtup bracket when there is added non-collision space. -c Trap musicsize if .ne. 16,20,24,29. -c 2.503 -c Enable arpeggio left shift with ?-x -c To do: In manual, arpeggio over 2 staves. -c Allow musicsize of 24 and 29. Had to define meter font size explicitly, -c also change font size for text dynamics, but not much else so far. -c Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn -c was called, causing error in printing replacement number. -c 2.502 -c Incorporate Dirk Laurie's patch to use { , } , for ties. -c Figure height adjustment: append +[n] -c Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?) -c 2.501 -c Readjust horizontal offset back to .8 in LineBreakTies -c Fix zero-subscript (iudorn) in putorn -c 2.50 -c Increase number of text-dynamics (dimension of txtdynq) per block -c from 12 to 41. -c Slur option n to override altered default curvature. -c Allow default ps slur curvature tweaks with Ap+/-c -c 2.416 -c Increase length of textdynq from 24 to 128 -c (Todo) Add comment in manual about blank lines at end. -c Configuration file: Define subroutine getpmxmod, check path in environment -c variable pmxmoddir, check existence, read lines into bufq after setup. -c Increase dimension on idynn in dodyn from 4 to 10 for max number -c of marks in a bar -c Increase allowable # of lines from 2000 to 4000. -c (To do) Replace definition of \liftpausc per Olivier. -c (To do) Fix extraneous error message if RD is placed at very end. -c 2.415 -c Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt -c instead of redefining \xnum. Change font used to \smallfont (as for -c normal xtups, -c Allow slur to start on rest. -c 2.414 -c Correct bug in crdacc when adding accidental to boundary causes number of -c segments to decrease -c Special rule for 3-accidental chords: If no 2nds, place them in order -c top, bottom, middle. -c 2.413 -c Correct bugs in chordal accidentals, related to left-shifted noteheads -c (a) Special problems with downstem when main note needs shifting -c (b) Assign 0 rank to boundary segs due to left-shifted noteheads -c 2.412 -c Change default horiz shift of start of seg 2 of linebreak slurs: -c -.7 for slurs, -1.2 for ties, -c Use height of start of seg 1 slur itself for end of 1 and start of 2. -c 2.411 -c "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2. -c "s" option in start of slur/tie as precursor to vert/horiz tweaks for end -c of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2. -c With "Apl", curvature adjustments on starting slur command apply to seg 1, -c those on ending command to seg 2. -c 2.410 -c "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine -c \xnum, \unbkt, \ovbkt. -c "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is -c flag, mult(5-9) is tweak value+16 -c 2.409 -c Bugfix in docrd for MIDI: Use original pitch in case main/chord were -c switched due to 2nds. -c Remove "o" from error message for "A" command. -c New syntax: optional instrument number separator ":" in movement -c break command to precede a 2-digit instrument. -c Conditional output formats for \setname at movement break to allow -c instrument numbers >9. -c Bugfix in coding to raise barno due to slur over line break (pmxb) -c Move date/version data statement in pmxab to a better place. -c 2.408 -c Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar). -c Bug fix in \liftPAusep in notex.for and in pmx.tex -c Character variables for version and date -c For up-stem single graces slurred to down-stem, shift slur start left by -c 0.8 so slur doesn't get too short. -c Initialize and slide mult, same as other full-program variables in /all/. -c 2.407 -c Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n, -c 2.406 -c Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing -c equalization). -c Put dimensions of double sharps and flats in crdacc (for chords). -c Bugfix: Use sepsymq in LineBreakTies(..) instead of '&' -c Use only first 4 bits of mult for multiplicity+8, so rest can be used -c for other stuff. -c Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict. -c 2.405: Not published but saved for safety. -c Option Aph to write \special{header=psslurs.pro} top of each page, so -c dviselec will work OK. -c 2.404 -c Allow slur to end on rest, but not start on a rest. Efaults height -c of ending is default height of start (before any automatic or user- -c defined djustments). User may adjust height as normal from default. -c 2.403 -c Bugfix: turn off repeated beaming patterns.at end of non-last voice. -c 2.402 -c Automatic repeated forced beams. Start with "[:" End with next explicit -c forced beam or end of input block. -c Increase # of forced beams per line of music per input block from 20 to 40 -c 2.401 -c Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies. -c Makes 1st part normal shape, and starts 2nd part a little further left. -c Enable arpeggios in xtuplets. Had to make time itar(narp) a real. -c 2.40 -c Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap. -c Fix non-ps-slur input to \midslur (third signed integer). Do not reverse -c sign for down-slurs. -c 2.359 -c Add error exit subroutine stop1 to make exit status g77-compatible.. -c Absolute octave on xtup chord note was 2 octave too high, fixed in getnote -c Fermata on vertically shifted rest: special trap in putorn() to set height. -c Correct multiple grace note spacing for small staves (in dograce, -c define wheadpt1 depending on staff size) -c 2.358 -c Allow curvature corrections at start of postscript slur, in dopsslur() -c Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust -c Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h] -c Make t[ID] act like s[ID]t, most mods in spsslur(). -c Add spsslur() to read in data for ps slurs, call from getnote. -c In beamstrt, save args for SetupB in common comipb to save them for -c 2nd call when xtup starts with rest -c Add spacing for ornament ")" as if it were accidental, in make2bar(). -c Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur() -c Horiz. shift start of ps grace slur, 2 places in dograce(). -c Horiz shift end of grace slur in endslur() -c Make st slurs into postscript ties. Separate subroutine dopsslur(), -c Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.) -c Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn. -c 2.357a -c Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote -c 2.357 -c Increase dimension for # of lit TeX strings from 52 to 83. -c Allow blank rest in middle of xtuplet. Only mods in g*etnote(). -c 2.356 -c Increased some dimensions from 30 to 40 to allow up to 40 pages. -c In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt(). -c Fix parsing of "f,h,H,HH" in sslur. -c Fix bug with cdot, note-level for slur termination (in getnote) -c 2.355 -c Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)], -c n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues -c Make midi recognize ps ties in doslur. -c Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote -c to get octave right. -c 2.354 -c With postscript slurs, make t-slurs real ties by inserting replacement -c macros \tieforisu, etc, defined in pmx.tex -c Check for open cresc or decresc at end of input block, using list[de]cresc -c Hairpin syntax conditional on postscript slurs. Backup to fill in start -c level, using new backfill(...). Separate height tweaks for -c start and finish. -c 2.353 -c K-0+n to transpose by half step (rather than just change key) -c Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of -c \mbrest's -c Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end -c of input block before movement break, and at start of block after -c movement break, using \newmovement rather than \setzalaligne, since -c former already redefines \stoppiece. In second case, set rptfg2='z'. -c Make clefq(nm) common between pmxb and getnote; change references in -c getnote at 'M' to array elements, setting all new clefs as you go. -c 2.352 -c Remove \parskip redefinition from pmx.tex; write it into TeX file when -c "Ae" is invoked. -c Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine -c \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH', -c translate them thru mapping to (1,4,5,6) as \midslur params, then let -c \psforts translate them back to ps slur macors. -c 2.351 -c Number slurs from 0 up instead of 11 down, anticipating postscript slurs. -c Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size. -c Increase length of basenameq to 44 characters everywhere. -c Increase dimension of mcpitch (midi-chord-pitch) to 20. -c Set default systems per page to 1 if nv>7 -c In pmxb, move place where isystpg is reset to 0, so that \eject gets -c written when there is just one system per page. -c 2.35 -c Cautionary accidentals with 'c' anywhere in note symbol. -c NEW pmx.tex with \resetsize to set size to normal or small depending on -c current \internote. Used with new coding in dograce() to get right -c new size in case user has \setsize'ed some lines to \smallvalue. For -c \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font. -c Affects pmx.tex. -c Continuation figure with fractional length. May now mix with other figures. -c If another figure follow Cont-fig, separate with colon. -c 2.342 -c Bugfix in getnote to recognize relative octave shift in grace at start of -c input block. -c In make2bar, initialize islhgt=0 earlier than before (possible solution -c to Suse g77 compile problem that I could not reproduce).. -c Bugfix in beamstrt & beamn1 for r2x6 c4D d d d -c 2.341 -c Syntax check: Forced page break page number must be > than previous. -c Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb. -c 2.34 -c New pmx.tex with redefined liftpausc -c Bug fix with dotted, non-beamed xtups. -c 2.332 -c Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads. -c Allow arbitrary pos. input to W in g1etnote and getnote. -c 2.331 -c Bug-fix in dodyn(..): typo on length of arg of txtdyn -c 2.33 -c Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata() -c 2.321 -c Rescale accidental shifts. Still use 7 bits but now map (0,127) -c onto (-1.,5.35) -c Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups -c 2.32 (Noticed after posting) -c Prohibit "/" as figure. -c 2.32 (Posted) -c Tidied up accidentals in chords, do spacing. -c Still to do: -c check for "(" on chord notes in spacing algo -c small accids -c double accids -c autoshift slurs -c 2.310 -c Extra call to precrd ahead of spacing chk, and single-note crd/acc -c shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time. -c 2.309 -c Alternate algo for accid shifts in chords. -c 2.308 -c Auto horiz. notehead shifting added to precrd. -c 2.307 -c Auto shifting of multiple accidentals in chords. -c "Ao" in main chord note to keep accidentals in order. Set nacc(28). -c If there are any manual main or chord note shifts, then -c If any manual shift is preceded by "A" then -c 1. Auto-shifting proceeds -c 2. "A"-shifts add to autoshifts -c 3. non-"A" shifts are ignored! -c Else (>0 man shifts, none has "A") -c No auto-ordering, No autoshifts, -c End if -c End if -c 2.306 -c Initialize legacy note level to middle C in case user forgets to set -c octave. -c Shift xtup note? -c Shift in elemskips rather than noteheads? -c 2.305 -c Stop pmxb from multiple endvolta's at start of new page. -c 2.304 -c "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on -c for multiple notes in the voice, "S:" last shortened note. -c 2.303 -c vshrink stuff all OK? Description is in pmxb. -c 2.302 -c Toggle vshrink with "Av". vshrink normally kicks in when \interstaff -c hits 20. This still needs work. -c Add " /" to last line if last char is not % or /. -c 2.301 -c Check in beamn1 for single note before multiplicity down-up. -c allow '.PMX' as well as '.pmx' -c 2.299 -c Correct typo in pmxb involving PMXbarnotrue. -c Replacement printed number for xtup: Unsigned integer after 'n' after 'x' -c Minor upgrade parsing xtuplet options 'x...' -c Correct dimension of nxtinbm in make2bar. -c 2.298 -c Account for doubled xtup notes in subroutine getx (user-defined spaces), -c by adding ndoub as an argument.. -c 2.297 -c Created and solved compiler problem. Put drawbm(NM) in its own common. -c Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar -c when \centerbar is used. -c Modify \mbrest & \CenterBar in pmx.tex to use \volta@endcor etc. Have PMX -c use right 2nd and 3rd args for \mbrest when key, meter, or clef changes. -c 2.296 -c Correct printed numbers for forced beams with multiple xtups. For each beam -c make list in setupb by voice of eloff (h-offset) and mtupv (printed #) -c Increase lengths of jobname and infileq by 20 characters -c Enable whole notes and breves as 1st or last note of xtup in beamn1 and -c beamend, and wholes in beamid. -c 2.295 -c Midi balance Ib[n1]:[n2]:...[nn] -c Single-slope beam groups [...]-[...] -c Trap "i" unless after accidental (main notes, xtups, chord notes) -c 2.294 -c Unequal xtups with "D" to double a note in an xtup. -c As above, "F" will (a) increase multiplicity by 1 for marked note and next -c one and (b) add a dot to the first one. -c Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on -c when "." is encountered, then correcting beam start time.(end of getnote) -c MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]... -c 2.293 -c Check for single notes spanning bar lines. -c Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup -c must be set in make2bar since beamstrt is not called, fixing problem with -c dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix -c problem when >2 staves. -c Add nodur to args of dodyn, so can check if stemless and avoid height tweak -c Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak -c 2.292a -c Undo syntax check for Type 2 or 3 TeX string starting in column 1. -c Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?! -c 2.292 -c Allow comments in xtuplets -c Enable multiple octave jumps in grace notes. -c Allow dynamics in xtuplets. -c Fix bug in getdyn searching for end of text string (correct length of lineq -c to 128) -c Fix bug in dodyn, must ignore horiz. interaction tweak for -c user-text (idno = 0) -c Syntax check for Type 2 or 3 TeX string starting in column 1 -c (NOTE: later undone!) -c Syntax check for page number > npages at forced line break. -c 2.291 -c Fix error in AS command (accid spacing for small systems), making only -c one spec per staff, nv total. -c Stop using MIDI channel 10 -c 2.29 -c Fix error in console output format for # of bytes used in MIDI file. -c Fix bug in dograce so no space is added between grace and main note when -c there is a MIDI-only accidental. -c Fix bug so oes?+4 works. It was too ugly to explain. -c ...Different ways of storing accidental specs on input and output. -c No longer zap \writezbarno in special situations. -c Fix bug in dyntxt level on rest -c Line spacing equalization. Add macros \starteq, \endeq, \spread, etc. -c Activate with Ae. (Maybe later could input alternate values for -c \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1 -c in the page, and \endeq on 1st note of next-to-last line in page. -c 2.28 -c Flip direction of forced beam "[f..." -c Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30) -c Fix bug in sliding ip's for txtdyn's -c In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99) -c 2.27 -c Comment out lines in dodyn checking number of dynamic marks found. Voice -c order may not be monotonic if two lines on a staff. -c Literal dynamic: D"[text]" -c 2.26 -c Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn, -c increasing dimension of idynn to 4 to allow 4 symbols on same note. -c Increase voltxtq length from 10 to 20. -c AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough -c accounting for ast's is done by defining effective headwidth -c whead1 in makebar2 to be 0.8*whead. -c 2.25 -c Fix logic bug with sepsym's when # of instruments changes. -c Slight increases in default offsets for hairpin starts after "p" -c 2.24 -c Hairpins D< or D> as toggle. -c Many automatic position tweaks for letter-group dynamics and hairpins. -c 2.23 -c Continued rhythmic shortcuts: space followed by "." or "," -c 2.22 -c In call to doslur, change tno(...) to tnote(...). This was only -c used when checking to slurs per stem directions, and should have been -c the note duration all along. -c MIDI-only accidental, bit 17 in nacc, or 27 in icrdat. -c Use "i" anywhere in note symbol. -c 2.21 -c Increase from 20 to 30 dimensions for movement breaks and midi sections. -c Fix out-of-order declarations per mutex comments -c Add "Bad error" and "Kluging" messages to log file. -c 2.197 -c add /comips/ to save tie-check midi variables -c For spacing of clef changes at start of input block, changed integer time -c lastnodur to prevtn, so it works with xtups. Possible incompatibility! -c 2.196 -c Fix Ickbug with time check in ncmid() -c Interchange \fermataup7 and \pausec to get proper alignment -c Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX. -c Add defn's of \hsp, \hspp to pmx.tex -c Fix pre-slurs on xtup chord notes. -c Fixed raised PAuse, define \liftPAuse -c Replace \zbreve\sk with \breve. -c Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what -c about "o" and 1 as shorthand for 16???? Search for "Kluge" -c Added "vo" (voice) as MIDI instrument 55 -c Allow 3-digit page numbers (search for "toppageno") -c Fix bug caused by prior fix (cancelling accid after bar line was ignored). -c Fix double accids in chords -c 2.194 -c Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if -c block. -c Add meter to MIDI file with every pause -c Purify FORTRAN? -c 2.193 -c Increased # of in-line TeX strings from 36 to 52. -c Fix entry of # of bytes in header of tempo/meter/key track to allow >255. -c 2.191 -c Event track: Tempos, meters, keys all together. Data in comevent -c 2.15 -c Pretty good midi capability. Still no attention to slurs on chord notes. -c 2.11 -c 11 Dec 99 c rm1 -c 11 Dec 99 "oes?", "oe?" -c 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes -c 11 Dec 99 Error message for shifted, repeated ornaments. -c 2.10 (Version 2.1) -c Fix bug with lowdot and xtuplets -c 2.09 -c Fix bug with multiple ornament heights over beams, when one is . or _ -c Error message from pmxa if rest on last note of xtup. -c Enable 12 slurs. -c Reinstate multiple rests at start of xtup. -c 2.07 -c Combine consecutive type-1 TeX strings. -c \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's. -c Fixed breve chord notes in docrd -c Check irest(28) as well as vxtup when setting nodur for chord notes, since -c vxtup isn't set until 1st *main* note in xtup -c Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing. -c 2.06+ -c Make deterministic the beam slope calculation when there are an even # of -c slopes in list and middle two are equal magnitude but opposite sign. -c pmxa Trap for "o:" before 1st note in block -c Partial bug fix for 64th notes in xtuplets. -c Make ixrest a vector, since with new time scheme may not finish xtup in -c same notes block. -c Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb) -c 2.06 -c Account for changes in nv when computing \interstaff. Add a counter -c nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever -c setting isysflb(iflb). Note nv can only change at a forced line break. -c Note also, iflb starts at 0! -c 2.05 -c Automatic start of new notes group with part 2 of staff-jump beam -c In make1bar, set irest bit 29 of lowest-voice note at same time, -c use as flag when making notes groups. -c For now, remove dummy blank line at end...it zaps terminal repeats. -c 2.02 -c Fixed slur-counting bug for multiple, slurred, aftergraces. -c 2.01 -c Increase to ask(1400) -c Increase max forced page breaks to 18 -c Define pausc for centered pause -c 2.0a -c Insert dummy blank line at very end to handle input files w/o terminal CR-LF -c pmx03r -c Option m[n] in S symbol to change musicsize (for parts) -c Double dotted rests now work. -c Write file name to log file -c Check existence of input file -c Allow 24-char jobname, may end with ".pmx" -c Comment out time stuff -c Replace 3-argument getarg with 2-argument + iargc -c Fix bug with negative noinst due to nint<=int replacement -c move lovation of iv in isdat1 to allow iv>7. -c Set nm=12 -c pmx03q -c replace int(x+.001) with nint(x) -c Write TeX file name to screen and to pml. -c Replace char(...) with chax(...) to sovle msdev bug. -c Bug fix: macro terminations when M is on a line by itself. -c Bug fix: don't accumulate space for XS in pmxa. -c Streamline Macros: use pointers to bufq instead of scratch files -c pmx03p -c Store input file in single character array bufq. -c lbuf(i)*2 is length of line i -c ipbuf is position just before next line to be read. -c pmx03 -c Optimize read/writes -c pmx02 -c Fix line count (for errors) when there are saved macros -c pmx01 -c In optimize mode, open/close macros (Watch out for residual zz files!) -c Command line input -c Option Ao to optimize, otherwise normal processing -c -ccccccc - parameter (nks=125,nm=24,mv=24576,maxblks=4000) - character*128 lnholdq - character*65536 bufq - integer*2 lbuf(maxblks) - common /comevent/ miditime,lasttime - logical slmon,dbltie - common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), - * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, - * slmon(0:nm),dbltie - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) - * ,miditran(nm),midtc(0:nm) - common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq - common /commus/ musize,whead20 - integer*4 nbars0(nks),nbars(nks),ipoe(nks),nbari(nks) - real*4 poe0(nks),poe(nks) - logical isfirst,optimize - logical*4 fexist - character*44 jobname - character*47 infileq - common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), - * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, - * idum,itsofar(nm),nib(nm,15),nn(nm), - * rest(nm,200),lenbr0,lenbr1,firstline,newmeter - logical rest,firstline,newmeter - common /comdiag/ n69(0:nm),n34(0:nm) - logical mmacrec,gottempo - common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, - * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), - * mmacrec,gottempo - common /truelinecount/ linewcom(20000) -c -c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing -c nmidsec section starts and stops based on PLAYING macros (not recording). -c -ccccccccccccccccccccccccc -c - data date /'28 Jan 12'/ - data version /'2617'/ -c -ccccccccccccccccccccccccc - data maxit,ncalls /200,0/ - data isfirst /.true./ -c itstart = mytime() - versionc = version -c -c Initialize midi parameters -c - gottempo = .false. - ismidi = .false. - debugmidi = .false. - relacc = .false. - mmacrec = .false. - nmidsec = 1 - mgap = 10 - miditime = 0 - lasttime = 0 - nmidcrd = 0 - nusebl = 0 - notmain = .false. - do 3 ivx = 1 , nm - twoline(ivx) = .false. - midinst(ivx) = 6 - midivel(ivx) = 127 - midibal(ivx) = 64 - miditran(ivx) = 0 -3 continue - do 12 icm = 0 , nm - imidi(icm) = 0 - restpend(icm) = .false. - trest(icm) = 0. - levson(icm) = 0 - levsoff(icm) = 0 - slmon(icm) = .false. - naccbl(icm) = 0 - n69(icm) = 0 - n34(icm) = 0 - msecstrt(icm,1) = 1 -12 continue -c -c End of midi parameter initialization -c - musize = 0 - optimize = .false. - numargs = iargc() - if (numargs .eq. 0) then - print*,'You could have entered a jobname on the command line,' - print*,' but you may enter one now:' - read(*,'(a)')jobname - numargs = 1 - else -c call getarg(1,jobname,idum) ! May need to replace this w/ next line - call getarg(1,jobname) - end if -10 ljob = lenstr(jobname,44) - if (ljob .gt. 44) then - print*,'Jobname is too long. Try again.' - call stop1() - else if (ljob .eq. 0) then - print*,'No was jobname entered. Try again.' - call stop1() - else if (numargs .eq. 2) then - if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then - optimize = .true. -c call getarg(2,jobname,idum) ! May need to replace this w/ next line - call getarg(2,jobname) - numargs = 1 - go to 10 - else - print*,'Illegal option on command line' - call stop1() - end if - end if -c -c Strip ".pmx" if necessary -c - ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX')) - if (ndxpmx .gt. 0) then - jobname = jobname(1:ndxpmx-1) - ljob = ljob-4 - end if -c -c Check for existence of input file -c - infileq = jobname(1:ljob)//'.pmx' - inquire(file=infileq,EXIST=fexist) - if (.not.fexist) then - inquire(file=jobname(1:ljob)//'.PMX',EXIST=fexist) - if (.not.fexist) then - print*,'Cannot find file '//infileq - call stop1() - else - infileq = jobname(1:ljob)//'.PMX' - end if - end if -c -c Open a log file -c - open(15,file=jobname(1:ljob)//'.pml') - call printl('This is PMX, Version '//version//', '//date) - ljob4 = ljob - call printl('Opening '//infileq) - open(18,file=infileq) -c -c Copy input file into common buffer -c - ipbuf = 0 - linewcom(1) = 1 - do 8 ilbuf = 1 , maxblks - ncomments = 0 -14 read(18,'(a)',end=9)lnholdq - lbuf(ilbuf) = lenstr(lnholdq,128) - if (lbuf(ilbuf) .eq. 0) then -c -c Blank line. Make it a single blank with length 1 -c - lbuf(ilbuf) = 1 - lnholdq = ' ' - end if -c -c Now line has at least one non blank character. Check for comment -c As of Version 260, do not copy comments into bufq -c But need to count %'s for error messaging -c if (lnholdq(1:1).eq.'%') go to 14 - if (lnholdq(1:1).eq.'%') then - ncomments = ncomments+1 - go to 14 - end if -c -c When here, have counted all preceding comments and have a real line -c - if (ilbuf .gt. 1) then - linewcom(ilbuf) = linewcom(ilbuf-1)+1+ncomments - else - linewcom(1) = 1+ncomments - end if - if (ipbuf+lbuf(ilbuf).gt.65536) then - print*,'Too many characters in file, stopping' - call stop1() - end if - bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) = lnholdq - ipbuf = ipbuf+lbuf(ilbuf) -8 continue - call printl('Too many lines in input file') - call stop1() -9 continue -c -c Insert dummy line to handle input files w/o CR-LF at end. -c - nlbuf = ilbuf-1 -c nlbuf = ilbuf -c bufq(ipbuf+1:ipbuf+3) = ' / ' -c lbuf(nlbuf) = 3 - close(18) - do 6 numit = 1 , maxit - if (optimize) call printl('Starting an iteration') -c -c When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0. -c Otherwise, nbars0 is the input -c When islast=.false., pmxb only returns poe's, otherwise does whole job -c - call pmxa(jobname,ljob4,isfirst,nsyst,nbars0,optimize) - if (.not.optimize) then - if (ismidi) then -c -c Set up channel numbers for midi. -c - numchan = 0 - do 11 iv = nv , 1 , -1 - if (twoline(iv)) then - midchan(iv,2) = numchan - numchan = numchan+1 - end if - midchan(iv,1) = numchan - numchan = numchan+1 -11 continue -c -c numchan will now be the number of channels, but max channel # is numchan-1 -c -c Set up velocities, balances, and midi-transpositions -c - do 13 iv = nv , 1 , -1 - if (twoline(iv)) then - midvelc(midchan(iv,2)) = midivel(iv) - midbc(midchan(iv,2)) = midibal(iv) - midtc(midchan(iv,2)) = miditran(iv) - end if - midvelc(midchan(iv,1)) = midivel(iv) - midbc(midchan(iv,1)) = midibal(iv) - midtc(midchan(iv,1)) = miditran(iv) -13 continue - end if -c -c TEMPORARY!!! -c - write(15,*)'nlbuf: ',nlbuf - ip1 = 1 - do 10000 ilb = 1 , nlbuf -c write(15,'(2i5,a40,3i5)')ilb,lbuf(ilb), -c * bufq(ip1:ip1+lbuf(ilb)-1), -c * (ichar(bufq(ip1+lbuf(ilb)-k:ip1+lbuf(ilb)-k)), -c * k=min(3,lbuf(ilb)),1,-1) - ip1 = ip1+lbuf(ilb) -10000 continue - iplast = ip1-1 -c -c Check to see if (1) last line is "<blank><blank>/" and (2) next to last -c line is "/" -c -c print*,'iplast:',iplast -c print*,'Last line:' -c print*,bufq(iplast+1-lbuf(nlbuf):iplast) -c print*,'Last char of next to last line:' -c print*,bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)) - if (bufq(iplast+1-lbuf(nlbuf):iplast) .eq. ' /') then - if (bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)).eq.'/') then - print*,'Removing last line of "<blank><blank>/"' - write(15,*)'Removing last line of "<blank><blank>/"' - nlbuf = nlbuf-1 - end if - end if -c - call pmxb(.true.,poe0,ncalls,optimize) - if (ismidi) then -c -c Write midi file -c - open(51,file=jobname(1:ljob)//'.mid') - if (debugmidi) open(52,file=jobname(1:ljob)//'.dbm') - call printl(' ') - call printl('Writing '//jobname(1:ljob)//'.mid') - call writemidi(jobname,ljob) - end if - close(15) - stop - end if - write(15,*)'nlbuf: ',nlbuf - ip1 = 1 - call pmxb(.false.,poe0,ncalls,optimize) - call poestats(nsyst,poe0,poebar0,devnorm0) -c -c Save initial deviation and line breaks for later comparison -c - if (numit .eq. 1) then - devpmx = devnorm0 - do 20 isys = 1 , nsyst - nbari(isys) = nbars0(isys) -20 continue - end if - call sortpoe(nsyst,poe0,ipoe) - do 1 iupord = nsyst , 1 , -1 - isysu = ipoe(iupord) - print*,'isysu=',isysu - write(15,*)'isysu=',isysu -c -c Skip if system isysu has poe0 < avg or isysd has poe0 > avg -c - if (poe0(isysu).lt.poebar0) go to 1 - do 5 idnord = 1 , nsyst - isysd = ipoe(idnord) - if (isysu.eq.isysd .or. nbars0(isysd).eq.1 - * .or. poe0(isysd).gt.poebar0) go to 5 - do 2 isyst = 1 , nsyst - nbars(isyst) = nbars0(isyst) - if (isyst .eq. isysu) then - nbars(isyst) = nbars(isyst)+1 - else if (isyst .eq. isysd) then - nbars(isyst) = nbars(isyst)-1 - end if -2 continue - call pmxa(jobname,ljob4,isfirst,nsyst,nbars,optimize) - call pmxb(.false.,poe,ncalls,optimize) - call poestats(nsyst,poe,poebar,devnorm) - if (devnorm .lt. devnorm0) then - devnorm0 = devnorm - poebar0 = poebar - do 4 isys = 1 , nsyst - nbars0(isys) = nbars(isys) - poe0(isys) = poe(isys) -4 continue - print*,'Improved with iup,idown,devnorm:', - * isysu,isysd,devnorm0 - write(15,*)'Improved with iup,idown,devnorm:', - * isysu,isysd,devnorm0 - write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) - write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) - call sortpoe(nsyst,poe0,ipoe) - go to 6 - end if -5 continue -1 continue -c -c If we get here, must have gone thru all switches and found nothing better, -c so done! -c - go to 7 -6 continue -7 continue - print*,'Optimum located, numit:',numit,', ncalls:',ncalls - write(15,*)'Optimum located, numit:',numit,', ncalls:',ncalls - print*,'Final error:',devnorm0,', initial error:',devpmx - write(15,*)'Final error:',devnorm0,', initial error:',devpmx - print*,'Percentage improvement:',100.*(1-devnorm0/devpmx) - write(15,*)'Percentage improvement:',100.*(1-devnorm0/devpmx) - call printl('Initial bars/system:') - write(*,'(5x,20i3)')(nbari(isys),isys=1,nsyst) - write(15,'(5x,20i3)')(nbari(isys),isys=1,nsyst) - call printl('Final bars/system:') - write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) - write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) - call pmxa(jobname,ljob4,.false.,nsyst,nbars0,optimize) - call pmxb(.true.,poe0,ncalls,optimize) -c itend = mytime() -c print*,'Elapsed time in ms:',itend-itstart -c write(15,*)'Elapsed time in ms:',itend-itstart - close(15) - end - subroutine accsym(nacc,acsymq,lacc) - character*3 acsymq - iacc = iand(nacc,7) - if (iacc .eq. 1) then - acsymq = 'fl' - lacc = 2 - else if (iacc .eq. 2) then - acsymq = 'sh' - lacc = 2 - else if (iacc .eq. 3) then - acsymq = 'na' - lacc = 2 - else if (iacc .eq. 5) then - acsymq = 'dfl' - lacc = 3 - else if (iacc .eq. 6) then - acsymq = 'dsh' - lacc = 3 - else - print*,'bad accidental: ',iacc - end if - return - end - subroutine addask(taskn,waskn,elaskn, - * fixednew,scaldold,tglp1,isudsp) - parameter (nm=24) - logical isudsp - common /comas1/ naskb,task(40),wask(40),elask(40) - common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) - common /comtol/ tol - if (isudsp) then -c -c Find which udsp we're dealing with -c - do 1 iudsp = 1 , nudsp - if (abs(taskn+tglp1-tudsp(iudsp)) .lt. tol) go to 2 -1 continue - print*,'You should note BEEE here in addask!' - call stop1() -2 continue -c -c Fixednew and scaldold must not be changed, since udsp's are already included -c in fsyst from pmxa, and udsp don't involve scaled space.. -c - if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then -c -c Must add user-defined space to what's there already. -c - wask(naskb) = wask(naskb)+udsp(iudsp) - else -c -c This place has no other space. -c - naskb = naskb+1 - task(naskb) = taskn - wask(naskb) = udsp(iudsp) - elask(naskb) = 0. - end if - else -c -c This is a normal space, no effect if smaller than existing space -c - if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then -c -c We already put in some space at this time -c Check if new one needs more space than old one at same time -c - if (waskn .gt. wask(naskb)) then - naskb = naskb-1 - else - return - end if - end if - naskb = naskb+1 - task(naskb) = taskn - wask(naskb) = waskn - elask(naskb) = elaskn - fixednew = fixednew+waskn - scaldold = scaldold+elaskn - end if - return - end - subroutine addblank(noteq,lnoten) - character*8 noteq - character*1 tchar - tchar = noteq - noteq = ' '//tchar - lnoten = 2 - return - end - subroutine addfb(nfb,iv,tnew,t1fb,t2fb,ulfbq,ifbadd) - parameter (nm=24) - integer nfb(nm) - common /comtol/ tol - real*4 t1fb(nm,20),t2fb(nm,20) - character*1 ulfbq(nm,20) - ifbadd = 1 - nfb(iv) = nfb(iv)+1 - do 1 ifb = nfb(iv)-1 , 1 , -1 - if (tnew .lt. t1fb(iv,ifb)-tol) then - t1fb(iv,ifb+1) = t1fb(iv,ifb) - t2fb(iv,ifb+1) = t2fb(iv,ifb) - ulfbq(iv,ifb+1) = ulfbq(iv,ifb) - else - ifbadd = ifb+1 - go to 2 - end if -1 continue -2 continue - t1fb(iv,ifbadd) = tnew - ulfbq(iv,ifbadd) = 'x' - return - end -c -c - subroutine addmidi(icm,nolev,iacc,isig,time,rest,endrest) - parameter(nm=24,mv=24576) - integer*2 mmidi,itk(25) - integer*4 itiesav(5,100) - character*1 notenumq - logical endrest,eximacc,it1found - logical rest - logical restpend,relacc,notmain,twoline,ismidi,crdacc - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) - * ,miditran(nm),midtc(0:nm) - logical slmon,dbltie - common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), - * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, - * slmon(0:nm),dbltie - common /comevent/ miditime,lasttime - common /comdiag/ n69(0:nm),n34(0:nm) -c -c Following variables are local but must be saved. I hope they are. -c (3/18/00) With g77 they are not, so add a common block here. -c -c integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12) - integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:15) - common /comips/ ipslon,lusebl,jusebl -c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ - data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/ -c -c Cancel out barline accidentals if there's a rest. -c - if (rest) naccbl(icm) = 0 -c -c Special path to insert dummy rest at end of a section -c - if (endrest) go to 20 -c - do 7 ion = 0 , nmidcrd -c -c check if this is only to get pitch of a chord note -c - if (notmain) go to 6 -c -c check for rest -c - if (rest) then -c -c Will not put in a note, but must update timing -c - if (.not.restpend(icm)) then -c -c First rest in sequence, save the time -c - restpend(icm) = .true. - trest(icm) = time - else - trest(icm) = trest(icm)+time - end if -c -c Note: code checkers don't like the above due to calling addmidi(trest(icm)) -c but this only happens if rest at end of section (endrest=.true.) (called -c from getmidi(), in which case these above lines are bypassed. -c - call chkimidi(icm) - return - end if -c -c time tics -c - if (imidi(icm).gt.0 .and. ion.eq.0) then - idur = mgap - else - idur = 0 - end if - if (restpend(icm)) then - restpend(icm) = .false. - idur = idur+nint(15*trest(icm)) - end if -c -c time to start of note -c - idurvar = isetvarlen(idur,nby2on) - if (nby2on .gt. 4) then - print*,'You got >4 bytes, something is bogus.' - call stop1() - end if - imidi(icm) = imidi(icm)+1 - do 2 i = 1 , nby2on -c -c imidi points to cell before highest (leftmost) byte. Start with lowest byte -c at far right, fill in backwards -c - mmidi(icm,imidi(icm)+nby2on-i) = mod(idurvar,256) - if (nby2on .gt. 1) idurvar = idurvar/256 -2 continue - imidi(icm) = imidi(icm)+nby2on-1 -c -c Note-on signal -c - imidi(icm) = imidi(icm)+1 -c mmidi(icm,imidi(icm)) = 9*16+icm - mmidi(icm,imidi(icm)) = 9*16+icmm(icm) -c -c Entry point for chord note pitch determination -c -6 continue -c -c Get midi pitch. On chord iteration, only do this first time (main note), -c since pitch was already computed for nonmain chord notes. -c - if (ion .eq. 0) then - ipsav = nolev*12./7+11 - ipsav0 = ipsav - if (isig .ne. 0) then -c -c Adjust for signature -c - notenumq = char(48+mod(nolev,7)) - if (isig.ge.index('4152630',notenumq)) then - ipsav = ipsav+1 - else if (-isig.ge.index('0362514',notenumq)) then - ipsav = ipsav-1 - end if - end if -c -c Deal with accidentals. -c -c iacc 0 1 2 3 4 5 6 7 -c effect X fl sh na X dfl dsh X -c iashft X -1 1 0 X -2 2 X -c - jacc = 0 - eximacc = .false. - if (iacc .gt. 0) then -c -c Adjust key-sig-adjusted pitch for explicit accidental (and exit) -c - jacc = iashft(iacc) - eximacc = .true. - if (.not.relacc) jacc = jacc+ipsav0-ipsav -c -c (Above) Shift applies to diatonic pitch but will be added to adjusted one -c - else if (naccim(icm) .gt. 0) then -c -c Possible implicit accidental from earlier in the bar -c Check for prior accid in this bar at this note level -c - do 3 kacc = 1 , naccim(icm) - if (laccim(icm,kacc) .eq. nolev) then - jacc = jaccim(icm,kacc) - eximacc = .true. - if (.not.relacc) jacc = jacc+ipsav0-ipsav - go to 4 - end if -3 continue -4 continue - end if -c -c Must split off the following if block from those above because chord -c notes can cause naccim>0, forcing us to miss other chord note's -c accross-bar-line accidental -c - if (naccbl(icm).gt.0 .and. .not.eximacc) then -c -c Possible carryover accid from prior bar (or prior same-pitch note). -c - do 21 kacc = 1 , naccbl(icm) - if (laccbl(icm,kacc) .eq. nolev) then - jacc = jaccbl(icm,kacc) -c -c Since we are *using* the bar-line accid, must flag it to be saved for next. -c - nusebl = nusebl+1 - jusebl(nusebl) = jacc - lusebl(nusebl) = nolev - if (.not.relacc) jacc = jacc+ipsav0-ipsav - go to 22 - end if -21 continue -22 continue - end if - ipsav = ipsav+jacc -c -c Midi transpositions -c - ipsav = ipsav+midtc(icm) - end if - if (notmain) then - mcpitch(nmidcrd) = ipsav -c -c Save pitch for tie checks -c - if (levson(icm).eq.nolev.and..not.slmon(icm)) - * ipslon(icm) = ipsav - else - imidi(icm) = imidi(icm)+1 - if (ion.eq.0) then - mmidi(icm,imidi(icm)) = ipsav - if (levson(icm).eq.nolev.and..not.slmon(icm)) - * ipslon(icm) = ipsav - else - mmidi(icm,imidi(icm)) = mcpitch(ion) - end if - end if - if (ion .eq. 0) then -c -c Only record accids for non-chords, main chord note during chord iteration -c and chordnotes on first call but not during iteration -c - if (iacc.gt.0) then -c -c Set marker for accidental for possible continuations later this bar -c but first check and clear earlier ones on same note. -c - do 23 kacc = 1 , naccim(icm) - if (laccim(icm,kacc) .eq. nolev) then - do 24 macc = kacc , naccim(icm)-1 - laccim(icm,macc) = laccim(icm,macc+1) - jaccim(icm,macc) = jaccim(icm,macc+1) -24 continue - go to 25 - end if -23 continue - go to 26 -25 continue - naccim(icm) = naccim(icm)-1 -26 continue -c -c Flag new accidental -c - naccim(icm) = naccim(icm)+1 - laccim(icm,naccim(icm)) = nolev - jaccim(icm,naccim(icm)) = iashft(iacc) - end if -c -c Bail if this is a chord note on the first call (from docrd) -c - if (notmain) then - call chkimidi(icm) - return - end if - end if -c -c Vel -c - imidi(icm) = imidi(icm)+1 -c mmidi(icm,imidi(icm)) = 127 - mmidi(icm,imidi(icm)) = midvelc(icm) - call chkimidi(icm) -7 continue -c -c For tie checks -c - if (levson(icm).gt.0.and..not.slmon(icm)) imidso(icm) = imidi(icm) -c -c Entry point for special rests at section ends (endrest=T) -c -20 continue -c -c Now insert all the ends -c - do 8 ioff = 0 , nmidcrd - if (ioff .eq. 0) then -c -c time to end -c - idur1 = nint(15*time) - if (.not.endrest .or. miditime.eq.nint(15*trest(icm))) then - idur = idur1-mgap - else - idur = idur1 - end if -c -c Deal with roundoff problems with 7-tuplets on half or quarters -c - if (idur1 .eq. 69) then - n69(icm) = n69(icm)+1 -c if (mod(n69(icm)+6,7) .gt. 3) idur = 58 - if (mod(n69(icm)+6,7) .gt. 3) idur = idur1-mgap-1 - else if (idur1 .eq. 34) then - n34(icm) = n34(icm)+1 - if (mod(n34(icm)+6,7) .gt. 4) idur = idur1-mgap+1 - end if - idurvar = isetvarlen(idur,nby2off) - if (nby2off .gt. 4) then - print*,'You got >4 bytes, something is bogus.' - call stop1() - end if - imidi(icm) = imidi(icm)+1 - call chkimidi(icm) - do 1 i = 1 , nby2off - mmidi(icm,imidi(icm)+nby2off-i) = mod(idurvar,256) - if (nby2off .gt. 1) idurvar = idurvar/256 -1 continue - imidi(icm) = imidi(icm)+nby2off-1 - else -c -c Inserting end of chord note, delta time is 0 -c - imidi(icm) = imidi(icm)+1 - mmidi(icm,imidi(icm)) = 0 - end if -c -c Note off -c - imidi(icm) = imidi(icm)+1 -c mmidi(icm,imidi(icm)) = 8*16+icm - mmidi(icm,imidi(icm)) = 8*16+icmm(icm) -c -c Pitch -c - imidi(icm) = imidi(icm)+1 - if (ioff .eq. 0) then - mmidi(icm,imidi(icm)) = ipsav - else - mmidi(icm,imidi(icm)) = mcpitch(ioff) - end if -c -c Vel -c - imidi(icm) = imidi(icm)+1 - mmidi(icm,imidi(icm)) = 0 - call chkimidi(icm) - if (endrest) then - return - end if -c -c print*,'Off, icm,imidi,ipsav,idur:',icm,imidi(icm),ipsav,time -c -8 continue - naccbl(icm) = nusebl - if (nusebl .gt. 0) then -c -c Fix tables of "bar-line" accids that are saved due to consecutive notes. -c - do 30 kacc = 1 , nusebl - laccbl(icm,kacc) = lusebl(kacc) - jaccbl(icm,kacc) = jusebl(kacc) -30 continue - nusebl = 0 - end if -c -c Begin tie checks -c - if (slmon(icm)) then -c -c Prior note had a slur start -c - if (levson(icm).eq.levsoff(icm) .and. iacc.eq.0) then -c -c We have a tie! (Assumed there would be no accidental on tie-ending note) -c Make a list of times of all events back to the one starting at imidso+1, -c which is at or before where the tie started. Ident tie start and stop by -c comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie) -c Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial -c time. - nsav4tie = 0 - imidt = imidso(icm) -10 nsav4tie = nsav4tie+1 - itiesav(1,nsav4tie) = igetvarlen(mmidi,icm,imidt,nbytes) - imidt = imidt+nbytes - do 11 j = 1 , 3 - itiesav(j+1,nsav4tie) = mmidi(icm,imidt+j) -11 continue - imidt = imidt+3 - if (nsav4tie .eq. 1) then - itiesav(5,1) = itiesav(1,1) - else - itiesav(5,nsav4tie) = itiesav(1,nsav4tie)+ - * itiesav(5,nsav4tie-1) - end if - if (imidt .ne. imidi(icm)) go to 10 -c -c Find which two pitches agree with saved slur pitch. -c - it1found = .false. - do 12 it2 = 1 , nsav4tie - if (itiesav(3,it2) .eq. ipslon(icm)) then - if (it1found) go to 13 - it1 = it2 - it1found = .true. - end if -12 continue - call printl( - * 'Program error, tied notes, send source to Dr. Don') - it1 = nsav4tie+1 - it2 = nsav4tie+1 -13 continue -c -c List the positions we want to keep -c - jsav = 0 - do 14 isav = 1 , nsav4tie - if (isav.eq.it1 .or. isav.eq.it2) go to 14 - jsav = jsav+1 - itk(jsav) = isav -14 continue - nsav4tie = nsav4tie-2 -c -c Now dump events it1 & it2, recompute times, restack mmidi. -c - imidi(icm) = imidso(icm) - do 15 isav = 1 ,nsav4tie - if (isav .eq. 1) then - idurvar = isetvarlen(itiesav(5,itk(isav)),nbytes) - else - idurvar = isetvarlen(itiesav(5,itk(isav))- - * itiesav(5,itk(isav-1)),nbytes) - end if - imidi(icm) = imidi(icm)+1 - do 16 i = 1 , nbytes - mmidi(icm,imidi(icm)+nbytes-i) = mod(idurvar,256) - if (nbytes .gt. 1) idurvar = idurvar/256 -16 continue - imidi(icm) = imidi(icm)+nbytes-1 - do 17 i = 2 , 4 - imidi(icm) = imidi(icm)+1 - mmidi(icm,imidi(icm)) = itiesav(i,itk(isav)) -17 continue -15 continue - end if - slmon(icm) = .false. - levsoff(icm) = 0 - if (.not.dbltie) levson(icm) = 0 - end if - if (levson(icm).gt.0) slmon(icm) = .true. - if (nmidcrd .gt. 0) nmidcrd = 0 - call chkimidi(icm) - return - end - subroutine addstr(notexq,lnote,soutq,lsout) - common /comlast/ islast,usevshrink - logical islast,usevshrink - character*(*) notexq - character*80 soutq - if (lsout+lnote .gt. 72) then - if (islast) write(11,'(a)')soutq(1:lsout)//'%' - lsout = 0 - end if - if (lsout .gt. 0) then - soutq = soutq(1:lsout)//notexq(1:lnote) - else - soutq = notexq(1:lnote) - end if - lsout = lsout+lnote - return - end - subroutine adjusteskz(ib,squez,istart,istop,poenom) -c -c For block ib, this adds accidental spaces to eskz, for use in getting -c length of xtup bracket and slopes of brackets and beams. -c - parameter (nm=24) - common /comas1/ naskb,task(40),wask(40),elask(40) - real*4 squez(80) - integer*4 istart(80),istop(80) - common /comnsp/ space(80),nb,prevtn(nm), - * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - character*1 ulq,sepsymq,sq - logical beamon,firstgulp,figbass,figchk,isfig - common /comeskz2/ eskz2(nm,200) - common /comtol/ tol - common /comntot/ ntot - inmin = istart(ib)+1 - do 10 iaskb = 1 , naskb - if (task(iaskb) .lt. to(istart(ib))-tol) go to 10 - eskadd = wask(iaskb)/poenom-elask(iaskb) - do 11 in = inmin , ntot - if (to(in) .gt. task(iaskb)-tol) then - eskz2(ivxo(in),ipo(in)) = eskz2(ivxo(in),ipo(in))+eskadd - if (abs(to(in)-task(iaskb)).lt. tol) inmin=inmin-1 - else - inmin = inmin+1 - end if -11 continue -10 continue - return - end - subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0) - logical figbass,ispoi,topmods,istype0,done,isbbm - common /comhsp/ hpttot(176) - common /compoi/ ispoi - common /combbm/ isbbm - common /comas3/ ask(2500),iask,topmods - character*40 pathnameq - character*44 basenameq - character*1 sq,chax - character*129 outq - sq = chax(92) - open(12,file=pathnameq(1:lpath)//basenameq(1:lbase)//'.tex') -c -c Transfer first 5 lines of main internal TeX file -c - do 11 il = 1 , 5 - call moveln(11,12,done) -11 continue - if (istype0) then -c -c Transfer literal TeX stuff from special scratch file -c - rewind(17) -10 call moveln(17,12,done) - if (.not.done) go to 10 - close(17) - end if -c -c Transfer next 2 lines from main scratch file -c - do 3 il = 1 , 2 - call moveln(11,12,done) -3 continue - if (ispoi) write(12,'(a)')sq//'input musixpoi' - if (isbbm) write(12,'(a)')sq//'input musixbbm' - if (figbass) then -c -c Transfer .fig data from scratch (unit 14) into external .tex (unit 12) -c -4 call moveln(14,12,done) - if (.not.done) go to 4 - close(14) - end if - iask = 0 - ihs = 0 -1 read(11,'(a129)',end=999)outq -c -c Hardspaces. -c - if (outq(1:5) .eq. sq//'xard') then - ihs = ihs+1 - outq(2:2) = 'h' - write(outq(12:15),'(f4.1)')hpttot(ihs) - lenout = 19 - go to 9 - end if -c -c This part hard-wires ask's into new .tex file as ast's -c -2 indxask = index(outq,sq//'ask') - if (indxask .ne. 0) then - iask = iask+1 - call putast(ask(iask),indxask,outq) - go to 2 - end if - lenout = llen(outq,129) -9 continue - write(12,'(a)')outq(1:lenout) -c -c If this is the line with "readmod", check for topmods. -c - if (topmods .and. outq(2:8).eq.'readmod') then - topmods = .false. - rewind(16) - do 7 il = 1 , 1000 - read(16,'(a129)',end=8)outq - lenout = llen(outq,129) -c -c We inserted the '%' in subroutine littex, to guarantee including blank. -c - write(12,'(a)')outq(1:lenout) -7 continue -8 continue - close(16) - end if - go to 1 -999 close(11) - close(12) - return - end - subroutine backfill(iunit,oldq,lenold,newq,lennew) -c -c In iunit, looks backward for oldq, overwrites newq -c Safest if both are same length! -c - character*128 lineq(200),nowq - character*(*) oldq,newq - linesback = 0 -1 continue - backspace(iunit) - read(iunit,'(a)')nowq - ndx = index(nowq,oldq(1:lenold)) -c -c Save the line just read -c - linesback = linesback+1 - lineq(linesback) = nowq - if (ndx .eq. 0) then - backspace(iunit) - go to 1 - end if -c -c If here, it's replacement time. -c - lineq(linesback) = nowq(1:ndx-1)//newq(1:lennew) - * //nowq(ndx+lenold:128) - backspace(iunit) - do 2 line = linesback , 1 , -1 - write(iunit,'(a128)')lineq(line) -2 continue - return - end - subroutine beamend(notexq,lnote) - parameter (nm=24) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - character*1 ulq,sepsymq,sq,ulqq,chax - logical beamon,firstgulp,figbass,figchk,flipend,btest, - * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm - common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 - common /comoct/ noctup - common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), - * mtupv(nm,9),nxtinbm(nm), - * islope(nm),xelsk(24),eloff(nm,9), - * nssb(nm),issb(nm),lev1ssb(nm,20) - common /comdraw/ drawbm(nm) - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /strtmid/ ihnum3,flipend(nm),ixrest(nm) - character*4 tempq - character*8 noteq - character*79 notexq - ip = ipo(jn) - multip = iand(mult(ivx,ip),15)-8 - if (ixrest(ivx) .eq. 4) then -c -c This is the LAST note in the xtup (i.e., all rests before). Make single. -c - nodur(ivx,ip) = 2**(4-multip) - call notex(notexq,lnote) - ixrest(ivx) = 0 - return - end if - nole = nolev(ivx,ip) -c -c Check for special situations with 2nds (see precrd) -c - if (btest(nacc(ivx,ip),30)) then - nole = nole - 1 - else if (btest(nacc(ivx,ip),31)) then - nole = nole + 1 - end if - if (.not.drawbm(ivx)) then -c -c Xtuplet with no beam, just put in the right kind of note -c - if (btest(islur(ivx,ip),30)) then -c -c Forced stem direction -c - ndsav = nodur(ivx,ip) - nodur(ivx,ip) = 2**(4-multip) - if (btest(nacc(ivx,ip-1),27)) - * nodur(ivx,ip)=nodur(ivx,ip)/2 - call notex(notexq,lnote) - nodur(ivx,ip) = ndsav - else - call notefq(noteq,lnoten,nole,ncmid(iv,ip)) - if (lnoten .eq. 1) call addblank(noteq,lnoten) - lnote = lnoten+3 - if (.not.btest(nacc(ivx,ip-1),27)) then -c -c Prior note is not regular-dotted -c - - if (multip .eq. 0) then - notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq - else if (multip .eq. -1) then - notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq - else if (multip .eq. 1) then - notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq - else if (multip .eq. 2) then - notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq - lnote = lnote+1 - else if (multip .eq. 3) then - notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq - lnote = lnote+2 - else if (multip .eq. -2) then - notexq = sq//'wh'//noteq - else if (multip .eq. -3) then - notexq = sq//'breve'//noteq - lnote = lnote+3 - else - print* - print*,'(Error in beamend, send source to Dr. Don)' - call stop1() - end if - else -c -c Prior note is regular-dotted so this one is halved -c - if (multip .eq. 0) then - notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq - else if (multip .eq. -1) then - notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq - else if (multip .eq. -2) then - notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq - end if - end if - end if - return - end if - call notefq(noteq,lnoten,nole,ncmid(iv,ip)) - lnote = 0 -c -c New way, with flipend, which was computed in beamstrt. -c - if (flipend(ivx) .and. btest(ipl(ivx,ip),30)) - * ulq(ivx,ibmcnt(ivx)) = chax(225-ichar(ulq(ivx,ibmcnt(ivx)))) - if (ip .gt. ibm1(ivx,ibmcnt(ivx))) then -c -c This is not a one-noter from beam-jump. Check if multiplicity has increased -c - if (btest(irest(ivx,ip-1),0)) then -c -c Prior note is a rest, check one before that -c - mp = iand(mult(ivx,ip-2),15)-8 - else - mp = iand(mult(ivx,ip-1),15)-8 - end if - if (multip .gt. mp) then -c -c Assume 1-3, 2-3, or 1-2 -c - do 2 imp = multip , mp+1 , -1 - call ntrbbb(imp,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) -2 continue - else if (btest(nacc(ivx,ip-1),27)) then -c -c 2nd member of dotted xtup -c - call ntrbbb(multip+1,'t', - * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) - end if - end if -c -c Beam termination and direction analysis -c - if (btest(irest(ivx,ip),23) .and. .not.isbjmp) then -c -c This is the end of the first segment in a jump-beam. ivbj1=ivx will be number -c of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the -c voice of the 2nd part of jumped beam. (May need special treatment for -c multi-segment jump-beams -c - isbjmp = .true. - ivbj1 = ivx - ivbj2 = 0 - end if - if (.not.btest(irest(ivx,ip),23)) then -c -c This is either a normal beamend or end of a sequence of jump-beam segments, -c so some sort of termination is required -c - ulqq = ulq(ivx,ibmcnt(ivx)) - if (.not.isbjmp .or. ivx.ne.ivbj2) then -c -c Normal termination -c - call ntrbbb(1,'t',ulqq,mod(ivx,24),notexq,lnote) - else -c -c Terminate a sequence of jump-beam segments. -c - ulqq = chax(225-ichar(ulqq)) - call ntrbbb(1,'t',ulqq,mod(ivbj1,24),notexq,lnote) - end if - end if -c -c And now the note -c - if (lnote .gt. 0) then - notexq = notexq(1:lnote)//sq//'qb' - else - notexq = sq//'qb' - end if - lnote = lnote+3 - isdotm = .false. - if (.not.vxtup(ivx)) then - if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then - if (.not.btest(iornq(ivx,ip),13)) then - notexq = notexq(1:lnote)//'p' - else - notexq = notexq(1:lnote)//'m' - isdotm = .true. - end if - lnote = lnote+1 - end if - end if -c -c 5/25/08 Allow >12 -c 5/9/10 Up to 24; replace 24 with 0 -c - if (.not.(isbjmp.and.ivx.eq.ivbj2)) then -c call istring(mod(ivx,12),tempq,len) - call istring(mod(ivx,24),tempq,len) - else -c call istring(mod(ivbj1,12),tempq,len) - call istring(mod(ivbj1,24),tempq,len) - end if - if (isbjmp .and. ivx.eq.ivbj2 - * .and..not.btest(irest(ivx,ip),23)) isbjmp=.false. - notexq = notexq(1:lnote)//tempq(1:len) - lnote = lnote+len - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+lnoten - if (isdotm) then - if (lnoten .eq. 1) then - notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}' - lnote = lnote+3 - else - notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) - lnote = lnote+1 - end if - end if - return - end - subroutine beamid(notexq,lnote) - parameter (nm=24) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - character*1 ulq,sepsymq,sq,ulqq,chax - logical beamon,firstgulp,figbass,figchk,flipend,btest, - * isfig,vxtup,isdotm,isbjmp,bar1syst,isdotted,isbj2,drawbm - character*79 notexq - common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 - common /comoct/ noctup - common /strtmid/ ihnum3,flipend(nm),ixrest(nm) - common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), - * mtupv(nm,9),nxtinbm(nm), - * islope(nm),xelsk(24),eloff(nm,9), - * nssb(nm),issb(nm),lev1ssb(nm,20) - common /comdraw/ drawbm(nm) - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /comask/ bar1syst,fixednew,scaldold, - * wheadpt,fbar,poenom - character*8 noteq - character*4 tempq - lnote = 0 - ip = ipo(jn) - nole = nolev(ivx,ip) -c -c Check for special situations with 2nds (see precrd) -c - if (btest(nacc(ivx,ip),30)) then - nole = nole - 1 - else if (btest(nacc(ivx,ip),31)) then - nole = nole + 1 - end if - if (.not.btest(irest(ivx,ip),0)) then - multip = iand(mult(ivx,ip),15)-8 -c if (btest(islur(ivx,ip-1),3)) multip = multip+1 -c -c (Above test OK since must have ip>1). Double dotted note preceding -c -c Move the following, because can't ask for note until after checking for -c embedded xtup with number, due to ordering/octave feature. -c -c call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) - end if - if (btest(irest(ivx,ip),28)) vxtup(ivx) = .true. - if (vxtup(ivx)) then -c -c In an xtup -c - if (btest(irest(ivx,ip),0)) then -c -c Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK -c - nodur(ivx,ip) = 2**(4-(iand(mult(ivx,ip),15)-8)) - call notex(notexq,lnote) -c -c Re-zero so next note does not get confused -c - nodur(ivx,ip) = 0 - return - end if -c if (multip.le.0) then -c if (multip.le.0 .or. -c * (multip.eq.1.and.btest(nacc(ivx,ip-1),18))) then - if (.not.drawbm(ivx)) then -c -c Xtuplet with no beam, just put in the right kind of note -c - if (btest(islur(ivx,ip),30)) then -c -c Forced stem direction -c - ndsav = nodur(ivx,ip) - nodur(ivx,ip) = 2**(4-multip) - if (btest(nacc(ivx,ip),19) .or. - * btest(nacc(ivx,ip),27)) then - nodur(ivx,ip)=3*nodur(ivx,ip)/2 - else if (btest(nacc(ivx,ip-1),27)) then - nodur(ivx,ip)=nodur(ivx,ip)/2 - end if - call notex(notexq,lnote) - nodur(ivx,ip) = ndsav - else -c -c Use ulq for stem direction -c - call notefq(noteq,lnoten,nole,ncmid(iv,ip)) - if (lnoten .eq. 1) call addblank(noteq,lnoten) - lnote = 3 - if (.not.btest(nacc(ivx,ip-1),27)) then -c -c Prior note is not regular-dotted -c - if (multip .eq. 0) then - notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) - else if (multip .eq. -1) then - notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) - else if (multip .eq. 1) then - notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) - else if (multip .eq. 2) then - notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx)) - lnote = 4 - else if (multip .eq. 3) then - notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx)) - lnote = 5 - else if (multip .eq. -2) then - notexq = sq//'wh' - end if - if (btest(nacc(ivx,ip),27)) then -c -c This note is regular dotted non-beamed xtup -c - notexq = notexq(1:3)//'p' - lnote = 4 - end if - else -c -c Prior note is regular-dotted so this one is halved -c - if (multip .eq. 0) then - notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) - else if (multip .eq. -1) then - notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) - else if (multip .eq. -2) then - notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) - end if - end if - notexq = notexq(1:lnote)//noteq - lnote = lnote+lnoten - end if - return - else if (nodur(ivx,ip).eq.0) then -c -c In the beamed xtup but not the last note -c - if (nodur(ivx,ip-1).gt.0) then -c -c Embedded Xtup, mult>0, starts here. Put in number if needed -c - nxtinbm(ivx) = nxtinbm(ivx)+1 - iud = 1 - if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') iud = -1 -c -c Get ip#, notelevel of middle note (or gap) in xtup -c - ipmid = ip+ntupv(ivx,nxtinbm(ivx))/2 - xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud, - * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8) - if (mod(ntupv(ivx,nxtinbm(ivx)),2).eq.0) xnlmid = (xnlmid+ - * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud, - * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2 - iflop = 0 - if (abs(xnlmid-ncmid(iv,ip)).lt.3.) iflop = -iud - iup = iud+2*iflop - if (btest(irest(ivx,ip),14)) then - iup = -iup - iflop = 0 - if (iud*iup .lt. 0) iflop = iup - end if -c -c Place number if needed -c - if (.not.btest(islur(ivx,ip),31)) then - mprint = igetbits(nacc(ivx,ip),5,22) - if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx)) - call putxtn(mprint,iflop,multip,iud,wheadpt,poenom, - * nolev1(ivx),islope(ivx),slfac, - * xnlmid,islur(ivx,ip),lnote,notexq,ncmid(iv,ip),nlnum, - * eloff(ivx,nxtinbm(ivx)),iup,irest(ivx,ip),.false.) - end if - call notefq(noteq,lnoten,nole,ncmid(iv,ip)) - else -c -c Intermediate note of xtup -c - call notefq(noteq,lnoten,nole,ncmid(iv,ip)) - end if - else -c -c Last note of xtup (but not last note of beam!) -c - call notefq(noteq,lnoten,nole,ncmid(iv,ip)) - end if - else if (btest(irest(ivx,ip),0)) then - call notex(notexq,lnote) - return - else - call notefq(noteq,lnoten,nole,ncmid(iv,ip)) - end if -c -c Check if multiplicity changes in a way requiring action -c - ipleft = ip-1 - if (btest(irest(ivx,ipleft),0)) ipleft = ipleft-1 - if (.not.btest(islur(ivx,ipleft),20)) then - multl = iand(15,mult(ivx,ipleft))-8 - else - multl = 1 - end if - mub = multip - multl - ipright = ip+1 - if (btest(irest(ivx,ipright),0)) ipright = ipright+1 - if (.not.btest(islur(ivx,ip),20)) then - multr = iand(15,mult(ivx,ipright))-8 - else - multr = 1 - end if - mua = multr-multip - if (mub.gt.0 .or. mua .lt. 0) then -c -c Multiplicity has increased from left or will decrease to right. Need action. -c - if (isbjmp .and. ivx.eq.ivbj2) then - ivb = ivbj1 - ulqq = chax(225-ichar(ulq(ivx,ibmcnt(ivx)))) - else - ivb = ivx - ulqq = ulq(ivx,ibmcnt(ivx)) - end if - if (mua .ge. 0) then - call ntrbbb(multip,'n',ulqq,ivb,notexq,lnote) - else if (multl .ge. multr) then - do 1 im = multip , 1+multr, -1 - call ntrbbb(im,'t',ulqq,ivb,notexq,lnote) -1 continue - else - do 2 im = 1+multr, multip - call ntrbbb(im,'r',ulqq,ivb,notexq,lnote) -2 continue - call ntrbbb(multr,'n',ulqq,ivb,notexq,lnote) - end if - else if (ip .gt. 1) then -c -c Check for 2nd member of dotted xtup -c - if (btest(nacc(ivx,ip-1),27)) call ntrbbb(multip+1,'t', - * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) - end if -c -c Now put in the note -c - if (lnote .gt. 0) then - notexq = notexq(1:lnote)//sq//'qb' - else - notexq = sq//'qb' - end if - lnote = lnote+3 - isdotm = .false. - if (isdotted(nodur,ivx,ip)) then -c -c rule out ')' -c - if (.not.btest(iornq(ivx,ip),13)) then - if (.not.btest(islur(ivx,ip),3)) then - notexq = notexq(1:lnote)//'p' - else -c -c Double dot -c - notexq = notexq(1:lnote)//'pp' - lnote = lnote+1 - end if - else - notexq = notexq(1:lnote)//'m' - isdotm = .true. - end if - lnote = lnote+1 - else if (btest(nacc(ivx,ip),19) - * .or. btest(nacc(ivx,ip),27)) then -c -c Special dotted notation for 2:1 xtup, or normal dot in xtup -c - notexq = notexq(1:lnote)//'p' - lnote = lnote+1 - end if -c -c 5/25/08 Allow >12 -c - if (.not.(isbjmp.and.ivx.eq.ivbj2)) then -c call istring(mod(ivx,12),tempq,len) - call istring(mod(ivx,24),tempq,len) - else -c call istring(mod(ivbj1,12),tempq,len) - call istring(mod(ivbj1,24),tempq,len) - end if - notexq = notexq(1:lnote)//tempq(1:len) - lnote = lnote+len - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+lnoten - if (isdotm) then - if (lnoten .eq. 2) then - notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}' - lnote = lnote+3 - else - notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) - lnote = lnote+1 - end if - end if - return - end - subroutine beamn1(notexq,lnote) - parameter (nm=24) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - character*1 ulq,sepsymq,sq - logical beamon,firstgulp,figbass,figchk,btest, - * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm - common /comoct/ noctup - common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 - common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), - * mtupv(nm,9),nxtinbm(nm), - * islope(nm),xelsk(24),eloff(nm,9), - * nssb(nm),issb(nm),lev1ssb(nm,20) - common /comdraw/ drawbm(nm) - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - character*8 noteq - character*79 notexq - ip1 = ipo(jn) - multip = iand(15,mult(ivx,ip1))-8 -c if (multip.le.0 .and. btest(irest(ivx,ip1),0)) then - if (.not.drawbm(ivx) .and. btest(irest(ivx,ip1),0)) then - lnote = 0 -c -c The rest was already written in beamstrt, so just get out of here -c - return - end if - nole = nolev(ivx,ipo(jn)) -c -c Check for special situations with 2nds (see precrd) -c - if (btest(nacc(ivx,ipo(jn)),30)) then - nole = nole - 1 - else if (btest(nacc(ivx,ipo(jn)),31)) then - nole = nole + 1 - end if - if (vxtup(ivx) .and. .not.drawbm(ivx)) then -c -c Xtuplet with no beam, just put in the right kind of note -c - if (btest(islur(ivx,ip1),30)) then -c -c Forced stem direction -c - ndsav = nodur(ivx,ip1) - nodur(ivx,ip1) = 2**(4-multip) - if (btest(nacc(ivx,ip1),19) .or. - * btest(nacc(ivx,ip1),27)) nodur(ivx,ip1)=3*nodur(ivx,ip1)/2 - call notex(notexq,lnote) - nodur(ivx,ip1) = ndsav - else - call notefq(noteq,lnoten,nole,ncmid(iv,ip1)) - if (lnoten .eq. 1) call addblank(noteq,lnoten) - lnote = 3 - if (multip .eq. 0) then - notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) - else if (multip .eq. -1) then - notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) - else if (multip .eq. 1) then - notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) - else if (multip .eq. 2) then - notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx)) - lnote = 4 - else if (multip .eq. 3) then - notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx)) - lnote = 5 - else if (multip .eq. -2) then - notexq = sq//'wh' - else if (multip .eq. -3) then - notexq = sq//'breve' - lnote = 6 - else - print* - print*,'(Error in beamn1, send source to Dr. Don)' - call stop1() - end if - if (btest(nacc(ivx,ip1),19) .or. btest(nacc(ivx,ip1),27)) then - notexq = notexq(1:3)//'p' - lnote = 4 - end if - notexq = notexq(1:lnote)//noteq - lnote = lnote+lnoten - end if - return - end if -c -c Check if mult. decreases from 1st note to 2nd -c - if (ibm2(ivx,ibmcnt(ivx)).gt.ip1 - * .or. btest(islur(ivx,ip1),20)) then -c -c More than one note or single-note before a multiplicity-down-up "][" -c - if (btest(islur(ivx,ip1),20)) then - multr = 1 - else if (.not.btest(irest(ivx,ip1+1),0)) then - multr = iand(15,mult(ivx,ip1+1))-8 - else - multr = iand(15,mult(ivx,ip1+2))-8 - end if - lnote = 0 - if (multr .lt. multip) then - do 1 im = multip , multr+1 , -1 - call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) -1 continue - end if - end if -c -c Put in the note -c - if (lnote .gt. 0) then - notexq = notexq(1:lnote)//sq//'qb' - else - notexq = sq//'qb' - end if - lnote = lnote+3 -c -c Check for dot -c - isdotm = .false. - if (.not.vxtup(ivx)) then - nd = nodur(ivx,ipo(jn)) - if (nd.ne.0) then - if (2**log2(nd).ne.nd) then - if (.not.btest(iornq(ivx,ip1),13)) then - if (.not.btest(islur(ivx,ip1),3)) then - notexq = notexq(1:lnote)//'p' - else -c -c Double dot -c - notexq = notexq(1:lnote)//'pp' - lnote = lnote+1 - end if - else - notexq = notexq(1:lnote)//'m' - isdotm = .true. - end if - lnote = lnote+1 - end if - end if - else if (btest(nacc(ivx,ip1),19) .or. - * btest(nacc(ivx,ip1),27)) then -c -c In an xtup with special 2:1 notation with a dot on 1st note, or normal dot -c - notexq = notexq(1:lnote)//'p' - lnote = lnote+1 - end if -c -c Do the number; 0 if 12 -c -c 5/25/08 allow >12 -c - if (.not.btest(irest(ivx,ip1),24)) then -c call istring(mod(ivx,12),noteq,len) - call istring(mod(ivx,24),noteq,len) - else -c call istring(mod(ivbj1,12),noteq,len) - call istring(mod(ivbj1,24),noteq,len) - end if - notexq = notexq(1:lnote)//noteq(1:len) - lnote = lnote+len - call notefq(noteq,lnoten,nole,ncmid(iv,ip1)) - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+lnoten - if (isdotm) then - if (lnoten .eq. 1) then - notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}' - lnote = lnote+3 - else - notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) - lnote = lnote+1 - end if - end if - return - end - subroutine beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib) - parameter (nm=24) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - character*1 ulq,sepsymq,sq - character*79 inameq - logical beamon,firstgulp,figbass,figchk,btest, - * isfig,vxtup,bar1syst,addbrack,flipend,xto,drawbm - common /comeskz2/ eskz2(nm,200) - common /comoct/ noctup - common /strtmid/ ihnum3,flipend(nm),ixrest(nm) - common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), - * mtupv(nm,9),nxtinbm(nm), - * islope(nm),xelsk(24),eloff(nm,9), - * nssb(nm),issb(nm),lev1ssb(nm,20) - common /comdraw/ drawbm(nm) - common /comas1/ naskb,task(40),wask(40),elask(40) - common /comask/ bar1syst,fixednew,scaldold, - * wheadpt,fbar,poenom - common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, - * isig,lastisig,fracindent,widthpt,height,idsig, - * lnam(nm),inameq(nm) - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 -c -c The following is just to save the outputs from SetupB for the case of -c xtups starting with a rest, where beamstrt is called twice. -c - common /comipb/ nnb,sumx,sumy,ipb(24),smed - character*8 noteq - character*79 notexq,tempq - integer nornb(nm),ihornb(nm,24) - real*4 space(80),squez(80) - logical novshrinktop,cstuplet,usexnumt - common /comnvst/ novshrinktop,cstuplet - common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), - * fullsize(nm),ivxfig2 - character*10 figq - ibc = ibmcnt(ivx) - ipb1 = ibm1(ivx,ibc) - multb = iand(15,mult(ivx,ipb1))-8 - ip = ipo(jn) -c -c Compute slopes and note offsets from start of beam. Inside SetupB, for each -c xtup in the beam, set eloff,mtupv (in comxtup) for printed number. -c - if (ixrest(ivx).eq.0 .and. .not.btest(nacc(ivx,ip),21)) - * call SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest(ivx)) - if (btest(nacc(ivx,ip),21)) then -c -c This is start of later segment of single-slope beam group so use slope and -c height from prior beam. Slope is already OK. -c - issb(ivx) = issb(ivx)+1 - nolev1(ivx) = lev1ssb(ivx,issb(ivx)) - end if - lnote = 0 - drawbm(ivx) = .true. - if (btest(irest(ivx,ipb1),28) .and. ixrest(ivx).ne.2) then - vxtup(ivx) = .true. - nxtinbm(ivx) = nxtinbm(ivx)+1 -c -c irest(28)=>Xtup starts on this note. Set up for xtuplet. -c Number goes on notehead side at middle note (or gap) of xtup, unless that -c puts it in staff, then it flops to stem (or beam) side. -c __ __ -c | | | O | | -c O | | O -c |___| O |__| | -c -c iud -1 -1 1 1 ...stem direction -c iflop 0 1 -1 0 ...direction of flop -c iup -1 1 -1 1 ...direction of number and bracket -c - iud = 1 - if (ulq(ivx,ibc) .eq. 'u') iud = -1 -c -c Get ip#, note level of middle note (or gap) in xtup -c - ipmid = ipb1+ntupv(ivx,nxtinbm(ivx))/2 - xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud, - * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8) - if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) xnlmid = (xnlmid+ - * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud, - * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2 - iflop = 0 - if (abs(xnlmid-ncmid(iv,ipb1)).lt.3.) iflop = -iud - iup = iud+2*iflop - if (btest(irest(ivx,ipb1),14)) then -c -c Alter iud, iflop, iup to flip number/bracket. (Stare at above pic) -c - iup = -iup - iflop = 0 - if (iud*iup .lt. 0) iflop = iup - end if -c -c Determine if a beam is to be drawn -c - do 5 ipp = ibm1(ivx,ibc),ibm2(ivx,ibc) - if (iand(15,mult(ivx,ipp))-8 .le. 0) then - drawbm(ivx) = .false. - go to 6 - end if -5 continue - drawbm(ivx) = .not.btest(islur(ivx,ibm1(ivx,ibc)),18) -6 continue -c -c Are we using tuplet.tex? -c - usexnumt = cstuplet .and. .not.drawbm(ivx) -c -c Place xtup number if needed -c - if (.not.btest(islur(ivx,ipb1),31) .or. multb.le.0) then - mprint = igetbits(nacc(ivx,ip),5,22) - if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx)) - call putxtn(mprint,iflop,multb,iud,wheadpt, - * poenom,nolev1(ivx),islope(ivx),slfac,xnlmid,islur(ivx,ipb1), - * lnote,notexq,ncmid(iv,ipb1),nlnum,eloff(ivx,nxtinbm(ivx)), - * iup,irest(ivx,ipb1),usexnumt) - end if - if (.not.drawbm(ivx)) then -c -c Xtuplet with no beam -c - if (.not.btest(islur(ivx,ipb1),31)) then -c -c Number printing has not been suppressed, so put in the bracket. -c scale = stretch factor for bracket if there are asx's -c xnsk = length of the bracket in \noteskips = (\elemskips)/(eon) -c - xnsk = (eskz2(ivx,ipb1+ntupv(ivx,nxtinbm(ivx))-1) - * -eskz2(ivx,ipb1))/squez(ib)/feon(space(ib)/squez(ib)) - if (iup .eq. 1) then - if (lnote .gt. 0) then - notexq = notexq(1:lnote)//sq//'ovbkt' - else - notexq = sq//'ovbkt' - end if - else - if (lnote .gt. 0) then - notexq = notexq(1:lnote)//sq//'unbkt' - else -c -c Introduced 12/5/98, req'd due to possible presence of in-line TeX -c - notexq = sq//'unbkt' - end if - end if - lnote = lnote+6 - if (iline.eq.1) then - smed = smed/(1.-fracindent) - end if - xslope = 1.8*smed*slfac - islope(ivx) = nint(xslope) - nolev1(ivx) = nlnum - nint(smed*eloff(ivx,1)) - if (islope(ivx) .eq. 0) nolev1(ivx) = nolev1(ivx)-1 - if (iup .eq. 1) nolev1(ivx) = nolev1(ivx)+4 - levbracket = nolev1(ivx) - if (iup.eq.1 .and. cstuplet) levbracket = levbracket-1 - call notefq(noteq,lnoten,levbracket,ncmid(iv,ipb1)) - if (lnoten .eq. 1) call addblank(noteq,lnoten) - notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' - lnote = lnote+lnoten+1 - if (xnsk .lt. 0.995) then - write(notexq(lnote+1:lnote+4),'(i1,f3.2)')0,xnsk - lnote = lnote+4 - else if (xnsk .lt. 9.995) then - write(notexq(lnote+1:lnote+4),'(f4.2)')xnsk - lnote = lnote+4 - else - write(notexq(lnote+1:lnote+5),'(f5.2)')xnsk - lnote = lnote+5 - end if - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - if (btest(mult(ivx,ipb1),4)) then -c -c Tweak slope of bracket -c - islope(ivx) = islope(ivx)+igetbits(mult(ivx,ipb1),5,5)-16 - end if - if (islope(ivx).lt.0 .or. islope(ivx).ge.10) then - notexq = notexq(1:lnote)//'{' - lnote = lnote+1 - if (islope(ivx) .lt. -9) then - write(notexq(lnote+1:lnote+3),'(i3)')islope(ivx) - lnote = lnote+3 - else - write(notexq(lnote+1:lnote+2),'(i2)')islope(ivx) - lnote = lnote+2 - end if - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - else - write(notexq(lnote+1:lnote+1),'(i1)')islope(ivx) - lnote = lnote+1 - end if -c -c Done with bracket -c - end if - if (ixrest(ivx) .eq. 1) then -c -c Put in the rest. Possible problem: Rest is a spacing char, but between -c beamstrt and beamn1 some non-spacing chars. are inserted. -c - if (multb .eq. 0) then - notexq = notexq(1:lnote)//sq//'qp' - lnote = lnote+3 - else if (.not.drawbm(ivx).and.multb.eq.1) then - notexq = notexq(1:lnote)//sq//'ds' - lnote = lnote+3 - else if (.not.drawbm(ivx).and.multb.eq.2) then - notexq = notexq(1:lnote)//sq//'qs' - lnote = lnote+3 - else if (.not.drawbm(ivx).and.multb.eq.3) then - notexq = notexq(1:lnote)//sq//'hs' - lnote = lnote+3 - else - notexq = notexq(1:lnote)//sq//'hpause' - lnote = lnote+7 - end if -c -c No need to come back through this subroutine (as would if rest starts bar -c & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing. -c - ixrest(ivx) = 0 - end if - return - end if -c -c End if block for non-beamed xtup start...note we returned -c - if (ixrest(ivx) .eq. 1) then -c -c Insert rest at start of beamed xtup. See above note for possible problem. -c - nodur(ivx,ipb1) = 2**(4-multb) - call notex(tempq,ltemp) - if (lnote .gt. 0) then - notexq = notexq(1:lnote)//tempq(1:ltemp) - else - notexq = tempq(1:ltemp) - end if - lnote = lnote+ltemp -c -c Re-zero just in case! -c - nodur(ivx,ipb1) = 0 - ibm1(ivx,ibc) = ibm1(ivx,ibc)+1 -c -c See if next note is a non-rest -c - if (.not.btest(irest(ivx,ipb1+1),0)) then - ixrest(ivx) = 2 - else -c -c Suppress reprinting xtup number next time through beamstrt -c - islur(ivx,ipb1+1) = ibset(islur(ivx,ipb1+1),31) -c -c Set new xtup start flag -c - irest(ivx,ipb1+1) = ibset(irest(ivx,ipb1+1),28) - end if - return - end if - end if -c -c Just ended if block for xtups -c - if (vxtup(ivx) .and. ipb1.eq.ibm2(ivx,ibc)) then -c -c Move actual note writing to beamend -c - ixrest(ivx) = 4 - return - end if - if (issb(ivx) .eq. 0) then -c -c 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed -c - iadj = igetbits(ipl(ivx,ipb1),6,11)-30 - if (iadj .ne. -30) then - nolev1(ivx) = nolev1(ivx)+iadj - do 2 isssb = 1 , nssb(ivx) - lev1ssb(ivx,isssb) = lev1ssb(ivx,isssb)+iadj -2 continue - end if - iadj = igetbits(ipl(ivx,ipb1),6,17)-30 - if (iadj .ne. -30) then - islope(ivx) = islope(ivx)+iadj - if (abs(islope(ivx)) .gt. 9) islope(ivx) = sign(9,islope(ivx)) - if (nssb(ivx) .gt. 0) then -c -c Cycle thru non-rest notes in SSBG, looking for bmstrts. -c - isssb = 0 - do 4 inb = 2, nnb - if (btest(nacc(ivx,ipb(inb)),21)) then -c -c Beam segment start. New start level - isssb = isssb+1 - lev1ssb(ivx,isssb) = - * lev1ssb(ivx,isssb)+islope(ivx)*xelsk(inb)/slfac - end if -4 continue - end if - end if - end if - iadj = igetbits(islur(ivx,ipb1),2,27) - addbrack = .false. - if (btest(ipl(ivx,ipb1),30)) then -c -c Check for altered starting polarity. Only in forced beams. Nominal start -c level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.). -c - if (ulq(ivx,ibc).eq.'u' .and. - * nolev1(ivx)+6.lt.nolev(ivx,ipb1)) then - if (lnote .eq. 0) then - notexq = sq//'loff{' - else - notexq = notexq(1:lnote)//sq//'loff{' - end if - lnote = lnote+6 - addbrack = .true. - else if (ulq(ivx,ibc).eq.'l' .and. - * nolev1(ivx)-6.gt.nolev(ivx,ipb1)) then - if (lnote .eq. 0) then - notexq = sq//'roff{' - else - notexq = notexq(1:lnote)//sq//'roff{' - end if - lnote = lnote+6 - addbrack = .true. - end if -c -c Check end level for possible flipping in forced beam. Have to do it -c here since with multiple voices, xelsk will not be preserved. -c - if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then - bmlev = nolev1(ivx)+6+islope(ivx)*xelsk(nnb)/slfac - flipend(ivx) = bmlev.lt.nolev(ivx,ibm2(ivx,ibc)) - else if (ulq(ivx,ibmcnt(ivx)) .eq. 'l') then - bmlev = nolev1(ivx)-6+islope(ivx)*xelsk(nnb)/slfac - flipend(ivx) = bmlev.gt.nolev(ivx,ibm2(ivx,ibc)) - end if - end if - call ntrbbb(multb+iadj,'i',ulq(ivx,ibc),ivx,notexq,lnote) -c -c Put in name of start level and slope, after correcting nolev1 if xtup -c started with a rest. -c - if (ixrest(ivx).eq.2) nolev1(ivx) = - * nint(nolev1(ivx)+xelsk(1)*islope(ivx)/slfac) - call notefq(noteq,lnoten,nolev1(ivx),ncmid(iv,ipb1)) - if (islope(ivx) .lt. 0) then - notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' - lnote = lnote+4+lnoten - write(notexq(lnote-2:lnote),'(i2,a1)')islope(ivx),'}' - else - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+1+lnoten - write(notexq(lnote:lnote),'(i1)')islope(ivx) - end if -c -c Check for beam-thk fine-tuning -c - if (iadj .gt. 0) then - do 1 imp = multb+iadj , multb+1 , -1 - call ntrbbb(imp,'t',ulq(ivx,ibc),ivx,notexq,lnote) -1 continue - end if -c -c If we shifted, must close with right bracket -c - if (addbrack) then - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - end if -c -c Get 'floor' zmin for figures -c Note: Will not come thru here on 1st note of unbeamed xtup, so figure height -c won't be adjusted. If anyone ever needs that, need to duplicate this -c functionality up above, before exiting. -c - if (figbass .and. (ivx.eq.1 .or. ivx.eq.ivxfig2)) then - if (ivx .eq. 1) then - ivf = 1 - else - ivf = ivxfig2 - end if - zmult = 1.2*(multb-1) - ymin = 100. - do 3 inb = 1, nnb - if (isfig(ivf,ipb(inb))) then - if (ulq(iv,ibc) .eq. 'u') then - ybot = nolev(iv,ipb(inb)) - else - ybot = islope(ivx)/slfac*xelsk(inb)+nolev1(ivx) - * -stemlen-zmult - end if - ymin = min(ymin,ybot) - end if -3 continue - maxdrop = ncmid(iv,ipb1)-4-ymin+5.01 - ifigdr(ivf,iline) = max(ifigdr(ivf,iline),maxdrop) - end if -c -c Compute ornament levels if needed -c - NomOrnLev = ncmid(iv,ipb1)+5 - iorn = 0 - do 8 inb = 1 , nnb - ip = ipb(inb) - if (.not.btest(iornq(ivx,ip),23)) go to 8 - if (btest(irest(ivx,ip),26) .and. ulq(ivx,ibc).eq.'l') then -c -c letter-dynamic or hairpin ending under down-beamed -c - iorn = iorn+1 - ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1 - * -1.2*(multb-1) - ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10) - else if (.not.btest(ipl(ivx,ip),10)) then -c -c Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F -c 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD -c -c Non-chord. There IS an ornament. Need ihornb only if upbeam, and if -c ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.) -c - if (ulq(ivx,ibc).eq.'u' .and. - * iand(iornq(ivx,ipb(inb)),4163566).gt.0) then - iorn = iorn+1 - iornq(ivx,ip) = ibset(iornq(ivx,ip),22) - ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1 - * +1.2*(multb-1) - ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev) - end if - else -c -c In a chord. Orn may be on main note or non-main or both. Set ihornb if -c upbeam and highest note has orn, or down beam and lowest. Find 1st chord note -c - do 10 icrd1 = 1 , ncrd - if (iand(255,icrdat(icrd1)) .eq. ip .and. - * iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 11 -10 continue -11 continue -c -c Find outermost note, min or max depending on beam direction ulq. xto is true -c if there's an ornament on that note. Expand orn list to include ._, since if -c on extreme chord note in beam, will move. -c So ornaments are all except 0,4,13 (,g,) -c - levx = nolev(ivx,ip) - xto = iand(iornq(ivx,ipb(inb)),4186094).gt.0 - icrdx = 0 - do 12 icrd = icrd1 , ncrd - if (iand(255,icrdat(icrd)) .ne. ip .or. - * iand(15,ishft(icrdat(icrd),-8)) .ne. ivx) go to 13 - levc = iand(127,ishft(icrdat(icrd),-12)) - if ((ulq(ivx,ibc).eq.'u'.and.levc.gt.levx) .or. - * (ulq(ivx,ibc).eq.'l'.and.levc.lt.levx)) then - levx = levc - icrdx = icrd - xto = iand(icrdorn(icrd),4186094).gt.0 - end if -12 continue -13 continue -c -c If there's orn on extreme note, do stuff -c - if (xto) then - iorn = iorn+1 - if (ulq(ivx,ibc) .eq. 'u') then - ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1 - * +1.2*(multb-1) - ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev) - else - ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1 - * -1.2*(multb-1) - ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10) - end if - if (icrdx .eq. 0) then -c -c Affected ornament is on main note -c - iornq(ivx,ip) = ibset(iornq(ivx,ip),22) - else - icrdorn(icrdx) = ibset(icrdorn(icrdx),22) - end if - end if - end if -8 continue -c -c Henceforth nornb will be a counter. -c - if (iorn .gt. 0) nornb(ivx)=1 - if (ixrest(ivx) .eq. 2) ixrest(ivx) = 0 - return - end - block data - parameter (nm=24) - common /comtol/ tol - common /comtrans/ cheadq - common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40), - * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), - * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), - * nistaff(0:40) - common /cblock/ - * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, - * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh - common /cominbot/ inbothd - logical usefig - common /comstart/ facmtr - character*60 cheadq - character*120 instrq,titleq,compoq - logical headlog - common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, - * inhead - common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, - * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, - * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, - * rtshfac - common /combmh/ bmhgt,clefend - common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), - * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), - * idynda2(99),levhssav(nm),listcresc,listdecresc - character*128 txtdynq - logical kbdrests - common /comkbdrests/ levbotr(8),levtopr(8),kbdrests - common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), - * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans - logical EarlyTransOn,LaterInstTrans - common /comsize/ isize(nm) -c - data tol /.001/ - data cheadq - * /' '/ - data gslfac /9./ - data instrq,titleq,compoq,headlog /3*' ',.false./ -c -c meter space (pts) = xb4mbr = musicsize*facmtr -c - data facmtr /0.55/ - data grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, - * flagfac,dotfac,bacfac,agc1fac,clefend,bmhgt - * / 1.3333,.4 , .7 , .3 , 0.2 , 2.0 , 1.0 , - * .7,.7 ,.9 ,.5 ,2.3 ,1.1 / - data rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,arpfac - * / 1.32 , 2.25 , 0.47 , 0.83 , 0.17 , 0.5 , 1.7 / - data rtshfac / 1.0 / - data isize /nm*0/ -c -c From other -c - data ptheight,widthpt, - * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, - * xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh - * / 740. , 524. , - * .50 , .25 , 0.4 , 0.4 , 0.2 , 12. ,21. , 12., - * 4 , 1.6 ,5.,5.7,1.071,2.714,16 ,16 / - data fracsys /30*0./ - data ivowg,hoh1,hoh2,hoh2h1 /0,0,0,0,0,1,1,1,1,1,1,1, -c * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, - * 2.2,1.7,1.2,0.7,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, - * -2.7,-2.2,-1.7,-1.2,-2.3,-2.1,-1.0,-1.7,-2.1,-1.6,-1.9,-2.3, - * -0.3,0.3 / - data kbdrests /.false./, - * levtopr /9,7,5,5,7,5,6,6/, levbotr /0,0,0,2,1,4,5,4/ - data EarlyTransOn, LaterInstTrans /2*.false./ - data iInstTrans /nm*0/ - end - subroutine catspace(space,squez,nnsk) - parameter (nkb=3999,maxblks=4000) - common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), - * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, - * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) - common /comtol/ tol - logical gotclef - do 16 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1 - if (abs(space-durb(iptr)) .lt. tol) then - if (abs(squez-sqzb(iptr)) .lt. tol) then -c -c Increment pre-existing entry -c - nnpd(iptr) = nnpd(iptr)+nnsk - return - end if - end if -16 continue -c -c Didn't find current duration & squez, so add a new entry. -c No particular reason to keep in order, so add at the end. -c - nnpd(nptr(ibarcnt+1)) = nnsk - durb(nptr(ibarcnt+1)) = space - sqzb(nptr(ibarcnt+1)) = squez - nptr(ibarcnt+1) = nptr(ibarcnt+1)+1 - return - end - character*1 function chax(n) -c -c The only reason for this seemingly do-nothing function is to get around an -c apparent bug in the Visual Fortran Standard Edition 5.0.A compiler! -c - chax = char(n) - return - end - subroutine checkdyn(lineq,iccount,ibar) - character*128 lineq - character*1 durq,chax - character*4 dynsymq - logical txtdyn - txtdyn = .false. -c -c On entry, iccount is on "D" -c - if (lineq(iccount+1:iccount+1) .eq. '"') then -c -c Dynamic text -c - iend = index(lineq(iccount+2:128),'"') - if (iend .eq. 0) then - call errmsg(lineq,iccount+1,ibar, - * 'Dynamic text must be terminated with double quote!') - call stop1() - end if -c -c Set iccount to character after 2nd ", and set ipm -c - iccount = iccount+iend+2 - ipm = index('- +',lineq(iccount:iccount)) - if (ipm .eq. 0) then - call errmsg(lineq,iccount,ibar, - * 'Expected "-", "+", or blank here!') - call stop1() - end if - else -c -c Expect ordinary dynamic -c - do 1 iend = iccount+2 , 128 - ipm = index('- +',lineq(iend:iend)) - if (ipm .gt. 0) go to 2 -1 continue -2 continue - if (iend-iccount.gt.5 .or. iend-iccount.lt.2) then - call errmsg(lineq,iend-1,ibar, - * 'Wrong length for dynamic mark!') - call stop1() - end if - read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')') - * dynsymq - idno = (index( - * 'ppppppp pp p mp mf f fp sfz ff fff ffff< > ', - * dynsymq)+3)/4 - if (idno .eq. 0) then - call errmsg(lineq,iccount+1,ibar,'Illegal dynamic mark!') - call stop1() - end if - iccount = iend - end if - if (ipm .ne. 2) then -c -c There is a vertical shift, have "+" or "-" -c - iccount = iccount+1 - if (index('0123456789',lineq(iccount:iccount)) .eq. 0) then - call errmsg(lineq,iccount,ibar, - * 'Expected integer here for vertical offset!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - idno = nint(fnum) - if (idno .gt. 63) then - call errmsg(lineq,iccount-1,ibar, - * 'Vertical offset for dynamic mark must be (-63,63)!') - call stop1() - end if - ipm = index('- +',durq) - if (ipm .eq. 0) then - call errmsg(lineq,iccount,ibar, - * 'Expected "+", "-", or blank here!') - call stop1() - end if - if (ipm .ne. 2) then -c -c There is a horizontal shift -c - iccount = iccount+1 - if (index('.0123456789',lineq(iccount:iccount)) .eq. 0) then - call errmsg(lineq,iccount,ibar, - * 'Expected number here for horizontal offset!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - idno = nint(10*fnum) - if (idno .gt. 255) then - call errmsg(lineq,iccount-1,ibar, - * 'Horizontal offset for dynamic mark must be (-25.5,25.5)!') - call stop1() - else if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibar, - * 'There should be a blank here!') - call stop1() - end if - end if -c -c iccount should be on the blank at the end of the entire symbol -c - end if - return - end - subroutine chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp) -c subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp, -c * icashft) - logical found1,iscacc,isarp,btest - integer icrdat(193) - found1 = .false. -c -c icashft will be max left shift of accid's in chord notes. -c Used only for spacing checks. -c Will include left shift of chord note itself. -c Rezero after use. -c - do 18 icrd = 1 , ncrd -c -c This if block cycles thru all chord notes on ivx,ip; then returns. -c - if (iand(255,icrdat(icrd)) .eq. ip .and. - * iand(15,ishft(icrdat(icrd),-8)) .eq. ivx) then - found1 = .true. - iscacc = iscacc .or. - * (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) -c -c Accid on this chord note, and it's not midi-only. -c -c irshft = igetbits(icrdot(icrd),7,20) -cc -cc Include increment for notehead shift -cc -c if (btest(icrdat(icrd),23)) then -c if (irshft .eq. 0) then -c irshft = 44 -c else -c irshft=irshft-20 -c end if -c end if -c if (irshft .ne. 0) then -cc -cc Accid on chord note is shifted. Include only left shift, in 20ths. -cc -c if (irshft .lt. 64) icashft = max(icashft,64-irshft) -c end if -c end if - isarp = isarp .or. btest(icrdat(icrd),25) - else if (found1) then - return - end if -18 continue - return - end - subroutine chkimidi(icm) - parameter (nm=24,mv=24576) - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - if (imidi(icm) .ge. mv) then - print* - print*,'Midi file is too long! It will be corrupted or worse' - write(*,'(a6,2x,4i8)') - * 'imidi:',imidi(0),imidi(1),imidi(2),imidi(3) - end if - return - end - subroutine chklit(lineq,iccount,literr) - character*128 lineq - character*1 charq,chax - literr = 0 - itype = 1 -17 call g1etchar(lineq,iccount,charq) - if (charq .eq. chax(92)) then - itype = itype+1 -c if (itype .eq. 2) then -c if (iccount .ne. 2 ) then -cc -cc type 2 or 3 tex string not starting in column 1 -cc -c literr = 3 -c return -c end if -c else if (itype .gt. 3) then - if (itype .gt. 3) then - literr = 1 - return - end if - go to 17 - end if - lenlit = itype -18 call g1etchar(lineq,iccount,charq) - if (charq.eq.chax(92)) then - call g1etchar(lineq,iccount,charq) - if (charq .ne. ' ') then -c -c Starting a new tex command withing the string -c - lenlit = lenlit+2 - if (lenlit .gt. 128) then - literr = 2 - return - end if - go to 18 - end if - else - lenlit = lenlit+1 - if (lenlit .gt. 128) then - literr = 2 - return - end if - go to 18 - end if - return - end - subroutine chkpm4ac(lineq,iccount,nacc,moved) -c -c Called after getting +/-/</> in a note (not rest). iccount is on the +-<>. -c Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits -c 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed -c numbers. If moved=.true., iccount on exit is on end of last number. -c If moved=.false., iccount still on +/- -c - logical moved,ishorz - character*128 lineq - character*1 durq - if (index('sfnA',lineq(iccount-1:iccount-1)).gt.0 .and. - * index('0123456789.',lineq(iccount+1:iccount+1)).gt.0) then -c -c Prior char was accid & next is #; this may be start of accidental shift. -c Must test for "." above in case we get "<" or ">" -c - ipm = index('- +< >',lineq(iccount:iccount))-2 - if (lineq(iccount+1:iccount+1).eq.'.' .and. - * index('0123456789',lineq(iccount+2:iccount+2)).eq.0) then -c -c Rare case of [accid][+/-].[letter]. Bail out -c - moved = .false. - return - end if - ishorz = ipm .gt. 1 -c -c Save iccount in case it's not accid shift and we have to reset. -c - icsav = iccount - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - if (ishorz .or. index('+-',durq).gt.0) then -c -c This has to be accidental shift. Set vert. shift. -c - if (.not.ishorz) then -c -c +/- syntax, both shifts set, vertical first -c - call setbits(nacc,6,4,int(ipm*fnum+32.5)) - ipm = index('- +',durq)-2 - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - else -c -c </> syntax, only horiz set -c - ipm = ipm-3 - end if -c -c Set horiz. shift -c - call setbits(nacc,7,10,nint(20*(ipm*fnum+5.35))) - iccount = iccount-1 - moved = .true. - else -c -c False alarm. Reset everything and flow onward -c - moved = .false. - iccount = icsav - end if - else -c -c Either prior char was not 'sfn' or next was not digit, so take no action -c - moved = .false. - end if - return - end - subroutine clefsym(isl,notexq,lnote,nclef) -c -c Returns string calling Don's TeX macro \pmxclef, for drawing small clefs. -c - character*(*) notexq - character*1 chax - nclef = iand(ishft(isl,-12),7) - if (nclef .eq. 0) then -c -c treble -c - nlev = 2 - else if (nclef .gt. 6) then -c -c French violin -c - nlev = 0 - else if (nclef .lt. 5) then -c -c C-clef -c - nlev = 2*nclef-2 - else -c -c F-clef -c - nlev = 2*nclef-6 - end if - notexq = chax(92)//'pmxclef'//chax(48+min(nclef,7)) - * //chax(48+nlev) - lnote = 10 - return - end - subroutine crdacc(nacc,naccid,micrd,nolevm,rmsshift,lasttime, - * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) -c -c nacc = accidental bitmap for main note -c naccid = # of accid's in chord -c micrd = array with icrd #'s for notes w/ acc's, 0=>main note -c nolevm = level of main note -c segrb(1|2,.) x|y-coord of right-bdry segment -c ksegrb(.) internal use; tells what defined this segment -c -2: Left-shifted notehead -c -1: Original right boundary -c 0: Main note accidental -c icrd: Chord-note accidental -c isetshft(i),i=1,naccid: what set shift for this accid, same codes -c icrdot0 = top-down level-rank of main note among accid-notes -c icrdot(icrd)(27-29) = level rank of chord-note among accid-notes -c twooftwo will be true 2nd time thru; signal to store shifts w/ notes -c - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - real*4 segar(5,2,6),segal(5,2,6),segrb(2,50),segrb0(2,50) - integer*4 nsegar(5),nsegal(5),micrd(10),iacctbl(6),ksegrb(50), - * isetshft(10),ksegrb0(50) - logical lasttime,mainnote,twooftwo - data nsegar / 3,4,3,3,2 /, nsegal / 2,4,3,3,2 / - data segar / -c -c Fancy sharp boundary. fl,sh,na,dfl,dsh -c - * -0.05,-0.38,-0.34,-.05, -.15,-1.4,-2.9,-3.0, -1.4, -1.2, -c * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. , -c meas value for y, natural is 1.6 - * -0.75,-0.20,-0.80,-.75, 0. , .96,-1.04,1.48, .96, 1.2, - * 0.00,-0.38, 0.00, 0. , 0. ,3.15, 1.64,3.0, 3.15, 0. , - * 0. , 0.00, 0. , 0. , 0. , 0. , 2.90, 0. , 0. , 0. , - * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , - * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. / - data segal / -c * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. , -cc (meas. value is 3.08) ^^^^ -cc Raise top of flat so it interferes with bottom of sharp - * -1.00,-1.02,-0.60,-1.65, -1.2,-1.4,-2.9, -3.0, -1.4, -1.2, - * 0.00,-1.20,-1.04, 0. , 0. ,3.15,-1.64,-1.48,3.15, 1.2, - * 0. ,-1.02, 0.00, 0. , 0. , 0. , 1.04, 3.0, 0. , 0. , - * 0. , 0.00, 0. , 0. , 0. , 0. , 2.9 , 0. , 0. , 0. , - * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , - * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. / -c -c iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6) -c - data iacctbl / 1 , 2 , 3 , 0 , 4 , 5 / -c -c Set up barrier segrb(iseg,ipoint) to define coords of corner points -c on stem+notes -c - do 11 iseg = 1 , nsegrb0 - segrb(1,iseg) = segrb0(1,iseg) - segrb(2,iseg) = segrb0(2,iseg) - ksegrb(iseg) = ksegrb0(iseg) -11 continue - nsegrb = nsegrb0 - rmsshift = 0. - shiftmin = 1000. - do 1 iwa = 1 , naccid -c -c Initialize shift for this note -c - shift = 0. - mainnote = micrd(iwa).eq.0 - isetshft(iwa) = -1 -c -c Get note level and accidental type -c - if (mainnote) then - nolev = nolevm - iacctype = iacctbl(igetbits(nacc,3,0)) - else - nolev = igetbits(icrdat(micrd(iwa)),7,12) - iacctype = iacctbl(igetbits(icrdat(micrd(iwa)),3,20)) - end if -c -c Cycle thru segments on right edge of this accidental -c - do 2 isega = 1 , nsegar(iacctype)-1 - ybotaseg = nolev+segar(iacctype,2,isega) - ytopaseg = nolev+segar(iacctype,2,isega+1) -c -c Cycle thru segments of right-hand barrier -c - do 3 isegrb = 1 , nsegrb-1 -c -c Must find all barrier segments that start below ytopseg & end above ybotseg -c - if (segrb(2,isegrb) .lt. ytopaseg) then -c -c Barrier seg starts below top of accid -c Check if barrier seg ends above bottom of accid -c - if (segrb(2,isegrb+1) .gt. ybotaseg) then - if (shift .gt. - * segrb(1,isegrb)-segar(iacctype,1,isega)) then - shift = segrb(1,isegrb)-segar(iacctype,1,isega) -c -c Record the cause of the shift -c - isetshft(iwa) = ksegrb(isegrb) - end if - end if -c -c Does barrier segment end above top of accid seg? -c - if (segrb(2,isegrb+1) .gt. ytopaseg) go to 4 - end if -3 continue -4 continue -2 continue - if (.not.btest(nacc,28) .and. abs(shift).gt.0.0001 - * .and. .not.lasttime) then -c if (nolev .eq. levmaxacc) then - if (nolev.eq.levmaxacc .and. isetshft(iwa).eq.-1) then - rmsshift = 1000. - return - end if -c -c Does the following properly account for left-shifted noteheads? -c -c Top-down rank of this note we just shifted -c - if (mainnote) then - irank = icrdot0 - else - irank = igetbits(icrdot(micrd(iwa)),3,27) - end if -c -c Compare level-rank of this note vs. that of note that caused the shift. -c This has effect of checking for basic interferences from top down. -c -c ksegrb(.) internal use; tells what defined this segment -c -2: Left-shifted notehead -c -1: Original right boundary -c 0: Main note accidental -c icrd: Chord-note accidental -c isetshft(i),i=1,naccid: what set shift for this accid, same codes -c - if (isetshft(iwa) .lt. 0) then - iranksetter = 0 - else if (isetshft(iwa) .eq. 0) then - iranksetter = icrdot0 - else - iranksetter = igetbits(icrdot(isetshft(iwa)),3,27) - end if - if (iranksetter.ne.0 .and. irank.ne.iranksetter+1) then - rmsshift = 1000. - return - end if - end if - rmsshift = rmsshift+shift**2 - if (lasttime .and. abs(shift).gt..0001) then - if (mainnote) then - if (.not.btest(nacc,29)) go to 10 - else - if (.not.btest(icrdat(micrd(iwa)),29)) go to 10 - end if -c -c If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there -c was a manual shift but auto-shift was zero, will not come thru here, but shift value -c will be left intact. -c - if (mainnote) then - shift = shift+.05*(igetbits(nacc,7,10)-107) - else - shift = shift+.05*(igetbits(icrdot(micrd(iwa)),7,20)-107) - end if -10 continue - if (twooftwo) then -c -c Record the shift for this accidental -c - if (shift .lt. -5.35) then - call printl(' ') - call printl('WARNING: auto-generated accidental '// - * 'shift too big for PMX, ignoring') - else - ishift = nint(20*(shift+5.35)) - if (mainnote) then - call setbits(nacc,7,10,ishift) - else - call setbits(icrdot(micrd(iwa)),7,20,ishift) - end if - end if - else -c -c This is the earlier call to precrd, so need minimum shift -c - shiftmin = min(shiftmin,shift) - end if - end if -c -c Bail out if this is the last accidental to check -c - if (iwa .eq. naccid) go to 1 -c -c Add this accidental to the right barrier! Count down from highest barrier segment, -c find 1st one starting below top of accid, and first one starting below bot. -c - do 5 ibelowtop = nsegrb , 1 , -1 - if (segrb(2,ibelowtop) .lt. - * nolev+segal(iacctype,2,nsegal(iacctype))) then - do 9 ibelowbot = ibelowtop , 1 , -1 - if (segrb(2,ibelowbot) .lt. - * nolev+segal(iacctype,2,1)) go to 6 -9 continue - print*,'Oops2!' - call stop1() - end if -5 continue - print*,'Ugh0! in crdaccs' - call stop1() -6 continue - netgain = nsegal(iacctype)-ibelowtop+ibelowbot -c -c Shift high segments up -c - if (netgain .ge. 0) then - do 7 isegrb = nsegrb , ibelowtop+1 , -1 - segrb(1,isegrb+netgain) = segrb(1,isegrb) - segrb(2,isegrb+netgain) = segrb(2,isegrb) - ksegrb(isegrb+netgain) = ksegrb(isegrb) -7 continue -c -c Set up 1st segment above accid -c - segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop) - segrb(2,ibelowtop+netgain) = - * nolev+segal(iacctype,2,nsegal(iacctype)) - ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop) - else -c -c netgain<0, must remove segments. Use same coding but reverse order, -c work from bottom up -c - segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop) - segrb(2,ibelowtop+netgain) = - * nolev+segal(iacctype,2,nsegal(iacctype)) - ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop) - do 12 isegrb = ibelowtop+1 , nsegrb - segrb(1,isegrb+netgain) = segrb(1,isegrb) - segrb(2,isegrb+netgain) = segrb(2,isegrb) - ksegrb(isegrb+netgain) = ksegrb(isegrb) -12 continue - end if -c -c Insert new segments -c - do 8 isega = 1 , nsegal(iacctype)-1 - segrb(1,ibelowbot+isega) = shift+segal(iacctype,1,isega) - segrb(2,ibelowbot+isega) = nolev+segal(iacctype,2,isega) - if (mainnote) then - ksegrb(ibelowbot+isega) = 0 - else - ksegrb(ibelowbot+isega) = micrd(iwa) - end if -8 continue -c -c Update number of barrier segments -c - nsegrb = nsegrb+netgain -cc -cc Temporary printout for boundary segments as built up -cc -c write(15,'()') -c write(15,'(a/(2f8.2,i5))')' y x kseg', -c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) -c write(15,'(a/(2i5))')' micrd isetshft', -c * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa) -cc -1 continue ! next accidental - if (lasttime .and. .not.twooftwo) then -c -c This is the final call on the pre-ask pass, so compute left-shift rqmt. -c - icashft = nint(-20*shiftmin) - end if -cc -cc Temporary printout for boundary segments -cc -c if (twooftwo) then -c write(15,'()') -c write(15,'(a/(2f8.2,i5))')' y x kseg', -c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) -c write(15,'(a/(2i5))')' micrd isetshft', -c * (micrd(iwa),isetshft(iwa),iwa=1,naccid) -c end if -cc - return - end - subroutine crdaccs(nacc,ipl,irest,naccid,kicrd,nolevm, - * levmaxacc,levminacc,icrdot0,twooftwo,icashft) -c -c nacc = accidental bitmap for main note -c naccid = # of accid's in chord -c kicrd = array with icrd #'s for notes w/ acc's, 0=>main note -c nolevm = level of main note -c -c This is called once per multi-accidental chord. In here, loop over all -c permutations of the order of accidental as stored in kicrd. Each time thru -c loop, call crdacc once, get rms shift. Only save permutation and rms value -c if it is less than old value. -c - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 -c -c Make consistent? 120106 -c integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) - integer*4 kicrd(10),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) - real*4 segrb0(2,50) - logical btest,tagged,manual,lshift,twooftwo -cc -cc Temporary printout of level-rankings -cc -c write(15,'()') -c do 98 iacc = 1 , naccid -c if (kicrd(iacc) .eq. 0) then -c write(15,'(3i5)')nolevm,icrdot0 -c else -c write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12), -c * igetbits(icrdot(kicrd(iacc)),3,27) -c end if -c98 continue -cc -c -c Initialize right-barrier -c - segrb0(1,1) = 0. - segrb0(2,1) = -1000. - segrb0(1,2) = 0. - segrb0(2,2) = 1000. - nsegrb0 = 2 - ksegrb0(1) = -1 - ksegrb0(2) = -1 -c -c Search for left-shifted notes, Make up the initial right-barrier, which -c will be good for all permutations. -c irest()(27) is set if any notes are left-shifted -c Must use ALL chord notes, not just ones w/ accid's. -c - if (btest(irest,27)) then - do 15 icrd = icrd1-1, icrd2 - if (icrd .eq. icrd1-1) then -c -c Main note -c -c lshift = btest(ipl,8) - lshift = btest(ipl,8) .or. btest(nacc,31) - if (lshift) nolev = nolevm - else -c -c Chord note -c - lshift = btest(icrdat(icrd),23) -c if (lshift) nolev = igetbits(icrdat(icrd),7,12) - if (lshift) then - nolev = igetbits(icrdat(icrd),7,12) - if (btest(nacc,31) .and. nolev.eq.nolevm+1) then -c -c This note is not really shifted, It is the upper of a 2nd with the main -c note on an upstem, and Main note must be shifted. -c nacc(31) signals the real truth. -c - lshift = .false. - end if - end if - end if - if (lshift) then - do 16 isegrb = 1 , nsegrb0-1 - if (segrb0(2,isegrb+1) .gt. nolev-1) then -c -c Add this notehead to the right boundary here. Move all higher segs up 2. -c - do 17 iiseg = nsegrb0 , isegrb+1 , -1 - segrb0(1,iiseg+2) = segrb0(1,iiseg) - segrb0(2,iiseg+2) = segrb0(2,iiseg) - ksegrb0(iiseg+2) = ksegrb0(iiseg) -17 continue - go to 18 - end if -16 continue -18 continue -c -c Insert notehead into list. Set kseg=-2 to signal notehead shift. -c - iiseg = isegrb+1 - segrb0(1,iiseg) = -1.2 - segrb0(2,iiseg) = nolev-1. - ksegrb0(iiseg) = -2 - segrb0(1,iiseg+1) = 0. - segrb0(2,iiseg+1) = nolev+1. - ksegrb0(iiseg+1) = -1 - nsegrb0 = nsegrb0+2 - end if -15 continue - end if -c -c Done setting right barrier for left-shifted noteheads -c - tagged = .false. - manual = .false. -c -c Preprocess to check for manual shifts. -c If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then -c If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then -c 1. Auto-shifting proceeds -c 2. "A"-shifts add to autoshifts -c 3. non-"A" shifts are ignored! -c Else (>0 man shifts, none has "A") -c No auto-ordering, No autoshifts, Observe all manual shifts. -c End if -c End if -c - maxmanshft = 0 - do 13 i = 1 , naccid - if (kicrd(i) .eq. 0) then -c -c Main note -c - manshft = igetbits(nacc,7,10) - if (manshft .ne. 0) then - manual = .true. - if (btest(nacc,29)) then - tagged = .true. - else -c maxmanshft = max(maxmanshft,64-manshft) - maxmanshft = max(maxmanshft,107-manshft) - end if - end if - else -c -c Chord note -c - manshft = igetbits(icrdot(kicrd(i)),7,20) - if (manshft .ne. 0) then - manual = .true. - if (btest(icrdat(kicrd(i)),29)) then - tagged = .true. - else -c maxmanshft = max(maxmanshft,64-manshft) - maxmanshft = max(maxmanshft,107-manshft) - end if - end if - end if -13 continue - if (manual) then - if (tagged) then -c -c zero out all untagged shifts -c - do 14 i = 1 , naccid - if (kicrd(i) .eq. 0) then - if (.not.btest(nacc,29)) call setbits (nacc,7,10,0) - else - if (.not.btest(icrdat(kicrd(i)),29)) - * call setbits (icrdot(kicrd(i)),7,20,0) - end if -14 continue - else -c -c There are manual shifts but none tagged. Only proceed if "Ao" was entered -c - if (.not.btest(nacc,28)) then - icashft = maxmanshft - return - end if - end if - end if - if (btest(nacc,28)) then -c -c Take the accidentals in order as originally input, then exit. -c - call crdacc(nacc,naccid,kicrd,nolevm,rmsshift,.true., - * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) - return -c end if - else if (naccid .eq. 3) then -c -c Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd -c then place in order top, bottom, middle. -c - do 20 i = 1 , 3 - if (kicrd(i) .eq. 0) then - irank = icrdot0 - nolev = nolevm - else - irank = igetbits(icrdot(kicrd(i)),3,27) - nolev = igetbits(icrdat(kicrd(i)),7,12) - end if - if (irank .eq. 1 ) then - micrd(1) = kicrd(i) - else - micrd(5-irank) = kicrd(i) - end if - if (irank .eq. 2) then - levmidacc = nolev - end if -20 continue - if (levmaxacc.ne.levmidacc+1 .and. - * levmidacc.ne.levminacc+1) then - call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true., - * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) - return - end if - end if - rmsmin = 100000. -c -c Initialize permutation array -c - do 7 i = 1 , naccid - iperm(i) = i -7 continue -c -c Start looping over permutations -c - do 8 ip = 1 , 5041 - if (ip .ne. 1) then -c -c Work the magic algorithm to get the next permutation -c - do 1 k = naccid-1 , 1 , -1 - if (iperm(k) .le. iperm(k+1)) go to 2 -1 continue -c -c If here, we just got the last permutation, so exit the loop over permutations -c - go to 10 -2 continue - do 3 j = naccid , 1 , -1 - if (iperm(k) .le. iperm(j)) go to 4 -3 continue -4 continue - it = iperm(j) - iperm(j) = iperm(k) - iperm(k) = it - is = k+1 - do 5 ir = naccid , 1 , -1 - if (ir .le. is) go to 6 - it = iperm(ir) - iperm(ir) = iperm(is) - iperm(is) = it - is = is+1 -5 continue -6 continue - end if -c -c New we have a permutation. Take icrd values out of kicrd and put them into -c micrd in the order of the permutation -c - do 9 i = 1 , naccid - micrd(i) = kicrd(iperm(i)) -9 continue -cc -cc Temporary printout -cc -c write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid) -cc - call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.false., - * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) -cc -cc Temporary printout -cc -c write(15,*)'perm done, rmsshift:',rmsshift -cc - if (rmsshift .lt. rmsmin) then -c -c Save this permutation, reset minrms -c - do 11 i = 1 , naccid - ipermsav(i) = iperm(i) - rmsmin = rmsshift -11 continue - end if -8 continue - print*,'Should not BEEEEEE here!' - call stop1() -10 continue -c -c Done looping, get info for the final choice -c - do 12 i = 1 , naccid - micrd(i) = kicrd(ipermsav(i)) -12 continue -cc -cc Temporary printout -cc -c write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid) -cc - call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true., - * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) - return - end - subroutine doacc(ihshft,ivshft,notexq,lnote,nacc,nolev,ncm,caut) - character*1 sq,chax - character*3 acsymq - character*8 noteq - character*79 notexq - logical btest,caut - sq = chax(92) - if (ihshft .eq. -107) ihshft=0 -cc -cc If main note shifted left, so shift accid. Terminate below, when acc. is done. -cc - if (ihshft .ne. 0) then -c -c Accid must be shifted horizontally -c - if (ihshft .lt. 0) then - notexq = sq//'loffset{' - ihshft = -ihshft - else - notexq = sq//'roffset{' - end if - hshft = .05*ihshft - if (hshft .lt. 1.) then - write(notexq(10:12),'(f3.2)')hshft - lnote = 12 - else - write(notexq(10:13),'(f4.2)')hshft - lnote = 13 - end if - notexq = notexq(1:lnote)//'}{'//sq - lnote = lnote+3 - else - notexq = sq - lnote = 1 - end if - if (btest(nacc,3)) then - notexq = notexq(1:lnote)//'big' - lnote = lnote+3 - end if - if (caut) then -c -c Cautionary accidental. Need to define bigcna,... in pmx.tex -c - notexq = notexq(1:lnote)//'c' - lnote = lnote+1 - end if - call accsym(nacc,acsymq,lacc) - notexq = notexq(1:lnote)//acsymq(1:lacc) - lnote = lnote+lacc - noleva = nolev - if (ivshft .ne. 0) noleva = noleva+ivshft-32 - call notefq(noteq,lnoten,noleva,ncm) - if (lnoten .eq. 1) call addblank(noteq,lnoten) - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+lnoten - if (ihshft .ne. 0) then -c -c Terminate horizontal shift -c - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - end if - return - end - subroutine docrd(ivx,ip,nodu,ncm,iv,tnow,soutq,lsout,ulq,ibmcnt, - * islur,nvmx,nv,beamon,nolevm,ihornb,nornb,stemlen, - * dotxtup,nacc) - parameter (nm=24,mv=24576) - common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), - * xinsnow,lowdot - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, - * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, - * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, - * rtshfac - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - logical lowdot,dotxtup - integer*4 ihornb(nm,24),nornb(nm) - character*1 ulq(nm,9),chax - character*7 nosymq - character*8 noteq - character*79 notexq,outq - character*80 soutq - logical btest,isleft,isright,beamon - character*79 inameq - common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, - * isig,lastisig,fracindent,widthpt,height,idsig, - * lnam(nm),inameq(nm) -c - common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), - * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans - logical EarlyTransOn,LaterInstTrans -c -c -c This subr. once produced notexq for entire chord. 10/18/97 altered to write -c chord notes as we go. 10/22/97 find range of icrd first. -c 2/25/98 moved rangefinding to precrd so done before slurs, so now -c on entry, icrd1, icrd2 define range of icrd for this chord. -c -c Set counter (for this note) for chord notes present. Set notmain=T. -c Will test for notmain=.true. in addmidi to tell whether to save pitch. -c - nmidcrd = 0 - notmain = .true. - crdacc = .false. - do 5 icrd = icrd1 , icrd2 - lnote = 0 - nolev = igetbits(icrdat(icrd),7,12) -c -c 3/8/03 save original pitch to use in midi, in case 2nds alter things. -c - nolevo = nolev -c -c Check for special situations with 2nds (see precrd). -c - if (btest(nacc,30)) then - if (nolev .eq. nolevm-1) nolev = nolevm - else if (btest(nacc,31)) then - if (nolev .eq. nolevm+1) nolev = nolevm - end if -c -c Lower dot for lower-voice notes?. Conditions are: -c 1. Dotted time value -c 2. Lower voice of two -c 3. Note is on a line -c 4. Not a rest (cannot be a rest in a chord!) -c. 5. Flag (lowdot) is set to true -c - if (lowdot .and. nvmx.eq.2 .and. ivx.le.nv) then - if (2**log2(nodu).ne.nodu .and. mod(nolev-ncm,2).eq.0) then - if (btest(icrdat(icrd),26)) then -c -c Note already in movdot list. Drop by 2. -c - call setbits(icrdot(icrd),7,0, - * igetbits(icrdot(icrd),7,0)-20) - else -c -c Not in list so just move it right now -c - call dotmov(-2.,0.,soutq,lsout,igetbits(islur,1,3)) - end if - end if - end if - if (btest(icrdat(icrd),26)) then -c -c Move the dot. -c - updotc = 0.1*(iand(127,icrdot(icrd))-64) - rtdotc = 0.1*(iand(127,ishft(icrdot(icrd),-7))-64) - call dotmov(updotc,rtdotc,soutq,lsout,igetbits(islur,1,3)) - end if - isleft = btest(icrdat(icrd),23) - isright = btest(icrdat(icrd),24) -c -c Check for ornament in chord. -c - if (icrdorn(icrd) .gt. 0) then - call putorn(icrdorn(icrd),nolev,nolevm,nodu,nornb,ulq, - * ibmcnt,ivx,ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout, - * ip,0,beamon,.true.) -c -c subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx, -c * ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt, -c * notcrd,beamon,iscrd) -c - call addstr(outq,lout,soutq,lsout) - end if -c -c Chord-note symbol. First check for breve -c - if (nodu .eq. 128) then - nosymq = chax(92)//'zbreve' - lsym = 7 - else -c -c Not a breve chord. Get first letters in chord-note symbol -c - if (isleft) then - nosymq = chax(92)//'l' - else if (isright) then - nosymq = chax(92)//'r' - else - nosymq = chax(92)//'z' - end if - if (nodu .ge. 64) then - nosymq = nosymq(1:2)//'w' - else if (nodu .ge. 32) then - nosymq = nosymq(1:2)//'h' - else - nosymq = nosymq(1:2)//'q' - end if - if (2**log2(nodu).eq.nodu .and. .not.dotxtup) then - lsym = 3 - else if (.not.btest(islur,3) .or. dotxtup) then -c -c Single dot -c - nosymq = nosymq(1:3)//'p' - lsym = 4 - else -c -c Double dot -c - nosymq = nosymq(1:3)//'pp' - lsym = 5 - end if - end if - if (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) then -c -c Accidental and not MIDI-only. Build up bits 0-3 of nacc -c - nactmp = igetbits(icrdat(icrd),3,20) -c -c Kluge for bigness. Only means 'As' has not been issued -c - if (bacfac .ne. 1.e6) nactmp = nactmp+8 - call doacc(igetbits(icrdot(icrd),7,20)-107, - * igetbits(icrdot(icrd),6,14), -c * notexq,lnote,nactmp,nolev,ncmid(iv,ip)) -c Get original nolev, not altered to deal with 2nds - * notexq,lnote,nactmp,igetbits(icrdat(icrd),7,12), -c * ncmid(iv,ip)) - * ncmid(iv,ip),btest(icrdat(icrd),31)) - notexq = notexq(1:lnote)//nosymq - crdacc = .true. - else - notexq = nosymq - end if - lnote = lnote+lsym -c -c Get note name (again if accid, due to possible octave jump) -c - call notefq(noteq,lnoten,nolev,ncm) - if (lnoten.eq.1) call addblank(noteq,lnoten) -c -c Put in note name -c - notexq = notexq(1:lnote)//noteq - lnote = lnote+lnoten - if (btest(icrdat(icrd),25)) then -c -c Arpeggio signal -c -c call putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) - call putarp(tnow,ivx,ip,nolev,ncm,soutq,lsout) - end if - call addstr(notexq,lnote,soutq,lsout) - if (ismidi) then -c -c Here is where we collect MIDI pitch info for the chord note. By checking -c notmain, addmidi(...) knows to just compute the -c pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi() -c for MAIN note, will put in note codes for all chord notes + main note. -c - kv = 1 - if (ivx .gt. iv) kv=2 - nmidcrd = nmidcrd+1 - if (nmidcrd .gt. 20) then - print* - print*,'21 chord notes is too many for midi processor' - call stop1() - end if -c -c Use original saved pitch level, unaltered by 2nds logic. -c -c call addmidi(midchan(iv,kv),nolevo, - call addmidi(midchan(iv,kv),nolevo-iTransAmt(instno(iv)), - * igetbits(icrdat(icrd),3,20),isig,1.,.false.,.false.) - end if -5 continue - notmain = .false. - return - end - subroutine dodyn(ivx,ip,nolev,ncm,ipl,islur,irest,nvmx,nv, - * beamon,ihornb,nornb,ulq,ibmcnt,nostem,soutq,lsout) - parameter (nm=24) -c -c Inputs are array *elements* except ihornb,nornb,ulq -c - common /commus/ musize,whead20 - common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), - * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), - * idynda2(99),levhssav(nm),listcresc,listdecresc - character*128 txtdynq - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - logical btest,beamon,upstem,nostem - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - logical fontslur,upslur,WrotePsslurDefaults - character*1 udqq,chax,ulq(nm,9) - character*4 dynstrq - character*5 numpq - character*48 dyntablq,tempq - character*79 notexq - character*80 soutq - integer*4 ihornb(nm,24),nornb(nm),idynn(10) - data dyntablq /'ppppppp pp p mp mf f fp sfz ff fff ffff'/ - numdyn = 0 -c -c Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values -c in idynn(1...4) -c - do 1 idyn = 1 , ndyn -c ivxtent = iand(idyndat(idyn),15) - ivxtent = iand(idyndat(idyn),15) - * +16*igetbits(idynda2(idyn),1,10) - if (ivxtent .eq. ivx) then - iptent = igetbits(idyndat(idyn),8,4) - if (iptent .eq. ip) then - numdyn = numdyn+1 - idynn(numdyn) = idyn - else if (iptent .gt. ip) then -c -c I don't think there are any more possible for this ivx,ip, so exit loop -c - go to 2 - end if -c else if (ivxtent .gt. ivx) then -c go to 2 - end if -1 continue -2 continue -c -c At this point there is a list of idyn's in idynn(1...numdyn) -c Compute level, and stem-dir'n-based horizontal tweaks -c - hoffsd = 0. -c -c Set upstem to false as default -c - upstem = .false. - if (btest(irest,0)) then -c -c It's a rest. Assume it doesn't go below the staff -c - lbot = ncm-4 - else if (.not.beamon) then - if (udqq(nolev,ncm,islur,nvmx,ivx,nv).eq.'u' .or. nostem) then - upstem = .true. - if (.not.btest(ipl,10)) then - lbot = min(nolev-1,ncm-4) - else - lbot = min(minlev-1,ncm-4) - end if - else - hoffsd = -.5 - if (.not.btest(ipl,10)) then - lbot = min(nolev-7,ncm-4) - else - lbot = min(minlev-7,ncm-4) - end if - end if - else - if (ulq(ivx,ibmcnt) .eq. 'u') then - upstem = .true. - if (.not.btest(ipl,10)) then - lbot = min(nolev-1,ncm-4) - else - lbot = min(minlev-1,ncm-4) - end if - else - hoffsd = -.5 - lbot = ihornb(ivx,nornb(ivx))+1 - if (lbot .eq. 1) then -c -c Kluge for non-beamed, down xtup, for which ihorb was never set. -c Assumes stem is shortened. -c - lbot = nolev-5 - end if - nornb(ivx) = nornb(ivx)+1 - end if - end if - lbot = lbot-5 - jtxtdyn1 = 1 -c -c Now ready to loop over current dyn's -c - do 3 icntdyn = 1 , numdyn - idynd = idyndat(idynn(icntdyn)) - idynd2 = idynda2(idynn(icntdyn)) - idno = igetbits(idynd,4,12) -c ivx = iand(15,idynd) - ivx = iand(15,idynd)+16*igetbits(idynd2,1,10) -c -c Build the command into notex in stages. Insert name & rq'd args in order: -c -c Command name -c hpstrt, hpcend, hpdend, pmxdyn -c ivx -c X X X -c level -c X X X -c hoff -c X X X X -c d-mark -c X -c - if (idno .eq. 0) then -c -c Text-dynamic -c - notexq = chax(92)//'txtdyn' - lnote = 7 - else if (idno .le. 12) then -c -c Letter-group -c - notexq = chax(92)//'pmxdyn' - lnote = 7 - else if (fontslur) then - lnote = 7 - if (idno .eq. 13) then -c -c Start a hairpin -c - notexq = chax(92)//'hpstrt' - else if (idno .eq. 14) then -c -c End crescendo -c - notexq = chax(92)//'hpcend' - else -c -c End decrescendo -c - notexq = chax(92)//'hpdend' - end if - else -c -c Postscript hairpins -c - lnote = 7 - if (idno .eq. 13) then - notexq = chax(92)//'Icresc' - else if (idno .eq.14) then - notexq = chax(92)//'Idecresc' - lnote = 9 - else - notexq = chax(92)//'Tcresc' - end if - end if - if (idno .ge. 13) then -c -c Put in voice number -c - if (ivx .le. 9) then - notexq = notexq(1:lnote)//char(48+ivx) - lnote = lnote+1 - else if (ivx .le. 19) then - notexq = notexq(1:lnote)//'{1'//char(38+ivx)//'}' - lnote = lnote+4 - else - notexq = notexq(1:lnote)//'{2'//char(28+ivx)//'}' - lnote = lnote+4 - end if - end if -c -c Begin setting level -c - lbot1 = lbot - if (idno.gt.0 .and. idno.le.5) then -c -c All letters are short so raise a bit. -c - lbot1 = lbot1+1 - else if (idno .ge. 13) then - lbot1 = lbot1+2 - end if -c -c Convert so reference is bottom line -c - lbot1 = lbot1-ncm+4 - if ((fontslur.and.idno.eq.13) .or. - * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then -c -c Hairpin start. Save level and user-tweak before applying user tweak. -c - levdsav(ivx) = lbot1 - levhssav(ivx) = 0 - if (btest(idynd,16)) levhssav(ivx) = -64+igetbits(idynd,7,17) - else if ((fontslur.and.idno.ge.14) .or. idno.eq.15) then -c -c Hairpin end; Compare level with saved start level before user-tweaks -c - lbot1 = min(lbot1,levdsav(ivx)) -c -c Save pre-tweak level -c - lpretweak = lbot1 - end if -c -c Check for user-defined vertical tweak -c - if (btest(idynd,16)) lbot1 = lbot1-64+igetbits(idynd,7,17) -c -c Now horizontal stuff -c - hoff = hoffsd -c -c Some special horizontal tweaks -c - if (upstem .and. idno.gt.0 .and. - * (idno.le.4 .or. idno.eq.8 .or. idno.eq.9)) hoff = hoff+.4 -c -c User-defined tweaks -c - if (btest(idynd2,0)) - * hoff = hoff+(igetbits(idynd2,9,1)-256)*.1 - if (numdyn .gt. 1) then -c -c Horizontal-interaction-based tweaks. -c -c Cases: -c numdyn type1 type2 type3 data used -c 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12) -c 2 hrpnend wrd-grp - ivowg,hoh2 -c 2 hrpnend hrpnstrt - hoh2h1(1...2) -c 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1 -c - if (idno.gt.0 .and. idno.le.12) then -c -c Word-group, may need vertical tweak to line up. -c - lbot1 = lbot1+ivowg(idno) -c -c Protecting against hp start-stop on same note -c - else if (((fontslur.and.idno.ge.14).or.idno.eq.15) - * .and. icntdyn.lt.numdyn) then -c -c Hairpin ending, check next type -c - if ((fontslur .and. - * igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13) - * .or. (.not.fontslur .and. - * ((igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13) - * .or. - * (igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.14)))) - * then -c -c Hairpin end then hairpin start, no words, (remember dealing with end now) -c - hoff = hoff+hoh2h1(1) - else -c -c Hairpin end then word-group, need idno for w-g to set hp offset -c - hoff = hoff + - * hoh2(igetbits(idyndat(idynn(icntdyn+1)),4,12)) - end if -c -c Protecting against hp start-stop on same note -c - else if (icntdyn.gt.1 .and. idno.gt.0 .and. - * ((fontslur.and.idno.lt.14).or. - * (.not.fontslur.and.idno.lt.15))) then -c -c Hairpin start, check prior type -c - if ((fontslur.and. - * igetbits(idyndat(idynn(icntdyn-1)),4,12).ge.14) - * .or. - * (.not.fontslur.and. - * igetbits(idyndat(idynn(icntdyn-1)),4,12).eq.15)) - * then -c -c Hairpin end then hairpin start, (remember dealing with start now) -c - hoff = hoff+hoh2h1(2) - else -c -c Hairpin start after word-group, need idno for w-g to set hp offset -c - hoff = hoff+ - * hoh1(igetbits(idyndat(idynn(icntdyn-1)),4,12)) - end if - end if - end if -c -c End of if-block for 2- or 3-way interactions. -c - if ((.not.fontslur) .and. idno.ge.13) -c -c Slur font and hairpin. Add hoff, and change from \interneote to \qn@width -c - * hoff = (hoff+.5)*6./2.5 -c -c Position corrections all done now. Put in the level. -c - if ((fontslur.and.idno.eq.13) .or. - * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then -c -c Hairpin start. -c - if (.not.fontslur) then -c -c Postscript hairpin start...inset placeholder for start level. - - notexq = notexq(1:lnote)//'{ }' - lnote = lnote+5 - end if - else -c -c Insert actual level in all cases except hairpin start -c Create string with level in it -c - if (lbot1 .gt. 9) then - numpq = '{' - write(numpq(2:3),'(i2)')lbot1 - numpq = numpq(1:3)//'}' - lnumpq = 4 - else if (lbot1 .gt. -1) then - numpq = char(48+lbot1) - lnumpq = 1 - else if (lbot1 .gt. -10) then - numpq = '{' - write(numpq(2:3),'(i2)')lbot1 - numpq = numpq(1:3)//'}' - lnumpq = 4 - else - numpq = '{' - write(numpq(2:4),'(i3)')lbot1 - numpq = numpq(1:4)//'}' - lnumpq = 5 - end if -c -c Level has now been computed and stored in numpq -c Append the level -c - notexq = notexq(1:lnote)//numpq(1:lnumpq) - lnote = lnote+lnumpq - end if - if (abs(hoff) .lt. .001) then -c -c No horiz offset -c - notexq = notexq(1:lnote)//'0' - lnote = lnote+1 - else -c -c Horizontal tweak -c - lform = lfmt1(hoff) - notexq = notexq(1:lnote)//'{' - lnote = lnote+1 - write(notexq(lnote+1:lnote+lform), - * '(f'//chax(48+lform)//'.1)')hoff - lnote = lnote+lform - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - end if - if (idno .eq. 0) then -c -c text-dynamic. Find the string and append it -c - do 4 jtxtdyn = jtxtdyn1 , ntxtdyn -c ivxip = ivx+16*ip - ivxip = ivx+32*ip - if (ivxip .eq. ivxiptxt(jtxtdyn)) go to 5 -4 continue - call printl('Abnormal stop in putdyn') - call stop1() -5 continue - ltxtdyn = lenstr(txtdynq(jtxtdyn),128) -c -c Font size based on musicsize -c - if (musize .eq. 20) then - notexq = notexq(1:lnote)//'{'//char(92)//'medtype' - * //char(92)//'it ' - lnote = lnote+13 - else if (musize .eq. 16) then - notexq = notexq(1:lnote)//'{'//char(92)//'normtype' - * //char(92)//'it ' - lnote = lnote+14 - else if (musize .eq. 24) then - notexq = notexq(1:lnote)//'{'//char(92)//'bigtype' - * //char(92)//'it ' - lnote = lnote+13 - else if (musize .eq. 29) then - notexq = notexq(1:lnote)//'{'//char(92)//'Bigtype' - * //char(92)//'it ' - lnote = lnote+13 - end if - notexq = notexq(1:lnote)//txtdynq(jtxtdyn)(1:ltxtdyn) - * //'}' - lnote = lnote+ltxtdyn+1 -c -c Reset jtxtdyn1 just in case >1 txtdyn on same note. -c - jtxtdyn1 = jtxtdyn+1 - else if (idno .le. 12) then -c -c Letter-group dynamic. Append the letter-group command -c - id = 4*idno - dynstrq = dyntablq(id-3:id) - id = lenstr(dynstrq,4) - notexq = notexq(1:lnote)//chax(92)//dynstrq(1:id) - lnote = lnote+1+id - end if - call addstr(notexq(1:lnote),lnote,soutq,lsout) - if ((.not.fontslur).and.idno.eq.15) then -c -c PS slurs on, hairpin is ending. Go back and set height at beginning. -c Add user-defined tweak to default level -c - lbot1 = lpretweak+levhssav(ivx) - if (lbot1 .gt. 9) then - numpq = '{' - write(numpq(2:3),'(i2)')lbot1 - numpq = numpq(1:3)//'}' - lnumpq = 4 - else if (lbot1 .gt. -1) then - numpq = char(48+lbot1) - lnumpq = 1 - else if (lbot1 .gt. -10) then - numpq = '{' - write(numpq(2:3),'(i2)')lbot1 - numpq = numpq(1:3)//'}' - lnumpq = 4 - else - numpq = '{' - write(numpq(2:4),'(i3)')lbot1 - numpq = numpq(1:4)//'}' - lnumpq = 5 - end if -c -c Construct string to search backwards for placeholder -c - if (ivx .le. 9) then - tempq = 'cresc'//char(48+ivx)//'{ }' - ltemp = 11 - else if (ivx .le. 19) then - tempq = 'cresc'//'{1'//char(38+ivx)//'}{ }' - ltemp = 14 - else - tempq = 'cresc'//'{2'//char(28+ivx)//'}{ }' - ltemp = 14 - end if - write(11,'(a)')soutq(1:lsout)//'%' - lsout = 0 - call backfill(11,tempq,ltemp, - * tempq(1:ltemp-5)//numpq(1:lnumpq),ltemp-5+lnumpq) - end if -3 continue -c -c Shrink arrays, decrease ndyn 111109 -c - do 6 icntdyn = numdyn, 1 , -1 - do 7 jdyn = idynn(icntdyn) , ndyn-1 - idyndat(jdyn) = idyndat(jdyn+1) - idynda2(jdyn) = idynda2(jdyn+1) -7 continue - ndyn = ndyn-1 -6 continue - end - subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,nacc,ig,ipl, - * farend, - * beamon,nolev,ncmidx,islur,nvmx,nv,ibmcnt,tnote,ulq) -c -c ip will be one LESS than current note, for way-after's before bar-end, -c It is only used to find ig. -c ig is returned to makeabar in case there's a slur that needs to be ended -c - parameter (nm=24) - logical beamon,stemup - common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, - * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, - * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, - * graspace(37), - * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), - * naccg(74),voltxtq(6),litq(83) - common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, - * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, - * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, - * rtshfac - common /comask/ bar1syst,fixednew,scaldold, - * wheadpt,fbar,poenom - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - common /comoct/ noctup - logical upg,slurg,slashg,bar1syst,upslur,btest,isgaft,iswaft, - * normsp,farend,fontslur,WrotePsslurDefaults - real*4 ptgr(37) - character*80 soutq - character*128 litq - character*79 notexq - character*20 voltxtq - character*10 figq - character*8 noteq,noteqGA - character*3 acsymq - character*1 sq,chax,udqq,ulq(nm,9) - common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), - * fullsize(nm),ivxfig2 - sq = chax(92) - isgaft = btest(ipl,29) - iswaft = btest(ipl,31) - normsp = .not. isgaft -c -c Find ig. -c - do 120 ig = 1 , ngrace - if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 121 -120 continue - print*,'Problem finding grace index in dograce' - stop -121 continue - ngs = ngstrt(ig) - mg = multg(ig) - wheadpt1 = wheadpt*fullsize(ivx) -c -c For way-after-graces at end of bar, must set the octave. -c - if (farend) then - noctup = 0 - if (ncm .eq.23) noctup = -2 - end if - if (slurg(ig) .and. .not.iswaft .and..not.isgaft) then - if (listslur .eq. 16777215) then - print* - print*,'You defined the twentyfifth slur, one too many!' - write(15,'(/,a)') - * 'You defined the twentyfifth slur, one too many!' - call stop1() - end if -c -c Slur on fore-grace. Get index of next slur not in use, from 23 down. -c - ndxslur = log2(16777215-listslur) - - end if - if (nng(ig) .eq. 1) then -c -c Single grace. -c - if (normsp) then -c -c Anything but GA -c - call addstr(sq//'shlft',6,soutq,lsout) - niptgr = nint(ptgr(ig)) -c -c Empirical tweak for postscript. -c -C if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3) -c++ - if (niptgr .lt. 10) then - call addstr(chax(48+niptgr)//'{',2,soutq,lsout) - else if (niptgr .lt. 100) then - write(notexq(1:2),'(i2)')niptgr - call addstr('{'//notexq(1:2)//'}{',5,soutq,lsout) - else - print*, - * 'Call Dr. Don if you really want grace note group > 99 pt' - stop - end if - else - call addstr(sq//'gaft{1.5}{',11,soutq,lsout) -c -c GA. Compute aftshft, for later use. -c - aftshft = grafac - if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+agc1fac - aftshft = aftshft*wheadpt - end if - if (slurg(ig) .and. .not.isgaft .and..not.iswaft) then -c -c Start slur on pre-grace. No accounting needed since will be ended very soon. -c - call notefq(noteq,lnoten,nolevg(ngs),ncm) - if (fontslur) then - if (upg(ig)) then - call addstr(sq//'islurd',7,soutq,lsout) - else - call addstr(sq//'isluru',7,soutq,lsout) - end if - else -c -c Start Postscript slur. -c - if (upg(ig)) then - call addstr(sq//'isd',4,soutq,lsout) - else - call addstr(sq//'isu',4,soutq,lsout) - end if - end if -c -c Print slur number, 23-ndxslur -c - lnote = 0 - if (23-ndxslur .lt. 10) then -c notexq = notexq(1:lnote)//chax(59-ndxslur) - notexq = chax(71-ndxslur) - lnote = 1 - else if (23-ndxslur .lt. 20) then -c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' - notexq = '{1'//chax(61-ndxslur)//'}' - lnote = 4 - else - notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' - lnote = 4 - end if -c if (11-ndxslur .lt. 10) then -c call addstr(chax(59-ndxslur)//noteq(1:lnoten),1+lnoten, -c * soutq,lsout) -c else -c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), -c * 4+lnoten,soutq,lsout) -c end if - call addstr(notexq(1:lnote)//noteq(1:lnoten), - * lnote+lnoten,soutq,lsout) - if (.not.fontslur) then -c -c Horizontal tweaks for postscript slur on single grace -c - stemup = .true. - if (upg(ig)) then -c -c Check for up-grace + down stem. Get stem direction -c - if (.not.beamon) then -c -c Separate note. Get stem direction. -c - stemup = udqq(nolev,ncmidx, - * islur,nvmx,ivx,nv) .eq. 'u' - else -c -c In a beam -c - stemup = ulq(ivx,ibmcnt) .eq. 'u' - end if -c -c Stop the shift if whole note -c - stemup = stemup .or. tnote.gt.63 - end if - if (stemup) then - call addstr('{-.3}',5,soutq,lsout) - else - call addstr('{-.8}',5,soutq,lsout) - end if - end if - end if - if (naccg(ngs) .gt. 0) then - call notefq(noteq,lnoten,nolevg(ngs),ncm) -c -c Save for checking octave shifts in GA -c - if (isgaft) then - lnotenGA = lnoten - noteqGA = noteq - end if -c - if (lnoten .eq. 1) call addblank(noteq,lnoten) - call accsym(naccg(ngs),acsymq,lacc) - call addstr(sq//'big'//acsymq(1:lacc)// - * noteq(1:lnoten),4+lacc+lnoten,soutq,lsout) - end if - if (slashg(ig)) then - notexq = sq//'grc' - lnote = 4 - else if (mg .eq. 0) then - notexq = sq//'zq' - lnote = 3 - else - notexq = sq//'zc' - do 61 i = 2 , mg - notexq = notexq(1:i+1)//'c' -61 continue - lnote = mg+2 - end if - if (upg(ig)) then - notexq = notexq(1:lnote)//'u' - else - notexq = notexq(1:lnote)//'l' - end if - call addstr(notexq,lnote+1,soutq,lsout) - call notefq(noteq,lnoten,nolevg(ngs),ncm) -c - if (isgaft .and. naccg(ngs).eq.0) then - lnotenGA = lnoten - noteqGA = noteq - end if -c - if (lnoten .eq. 1) call addblank(noteq,lnoten) - call addstr(noteq,lnoten,soutq,lsout) - if (slashg(ig)) call addstr(sq//'off{-'//sq// - * 'noteskip}',16,soutq,lsout) -c -c Above code needed since slashg causes spacing -c - if (slurg(ig) .and. (iswaft.or.isgaft)) then -c -c Terminate slur on single after-grace -c -c ndxslur = igetbits(ipl,4,23) - ndxslur = igetbits(ipl,5,23) - call notefq(noteq,lnoten,nolevg(ngs),ncm) - call addstr(sq//'tslur',6,soutq,lsout) -c -cc Print 11-ndxslur -c Print 24-ndxslur -c -c if (11-ndxslur .lt. 10) then - if (23-ndxslur .lt. 10) then -c call addstr(chax(59-ndxslur)//noteq(1:lnoten), - call addstr(chax(71-ndxslur)//noteq(1:lnoten), - * 1+lnoten,soutq,lsout) - else if (23-ndxslur .lt. 20) then - call addstr('{2'//chax(61-ndxslur)//'}'//noteq(1:lnoten), - * 4+lnoten,soutq,lsout) - else -c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), - call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten), - * 4+lnoten,soutq,lsout) - end if - slurg(ig) = .false. - listslur = ibclr(listslur,ndxslur) - end if - call addstr('}',1,soutq,lsout) -c -c+++ Try to fix loss of octave with single gaft -c -c if (isgaft) call addstr(sq//'zcharnote'//noteq(1:lnoten)//'{~}', -c * 13+lnoten,soutq,lsout) - if (isgaft) then - itrans = 0 - do 1 i = 1 , lnotenGA - if (noteqGA(i:i) .eq. chax(39)) then - itrans = itrans+7 - else if (noteqGA(i:i) .eq. chax(96)) then - itrans = itrans-7 - end if -1 continue - if (itrans. eq. -14) then - call addstr(sq//'advance'//sq//'transpose-14',21, - * soutq,lsout) - else if (itrans .eq. -7) then - call addstr(sq//'advance'//sq//'transpose-7',20, - * soutq,lsout) - else if (itrans .eq. 7) then - call addstr(sq//'advance'//sq//'transpose7',19, - * soutq,lsout) - else if (itrans .eq. 14) then - call addstr(sq//'advance'//sq//'transpose14',20, - * soutq,lsout) - end if - end if - else -c -c Multiple grace. Put in literally. Compute beam stuff -c - sumx = 0. - sumy = 0. - sumxy = 0. - sumxx = 0. - sumyy = 0. - x = 0. - do 118 ing = ngs , ngs+nng(ig)-1 - if (ing.gt.ngs .and. naccg(ing).gt.0) x = x+acgfac - y = nolevg(ing) - sumx = sumx + x - sumy = sumy + y - sumxy = sumxy + x*y - sumxx = sumxx + x*x - sumyy = sumyy + y*y - x = x+emgfac -118 continue - delta = nng(ig)*sumxx-sumx*sumx - em = (nng(ig)*sumxy-sumx*sumy)/delta - islope = nint(0.5*em*gslfac) - if (iabs(islope) .gt. 9) islope = isign(9,islope) - beta = (sumy-islope/gslfac*sumx)/nng(ig) - nolev1 = nint(beta) -c -c Back up -c - notexq = sq//'settiny'//sq//'off{' - if (normsp) then - write(notexq(14:18),'(a1,f4.1)')'-',ptgr(ig) - call addstr(notexq(1:18)//'pt}',21,soutq,lsout) - finalshift = ptgr(ig) - else - aftshft = wheadpt*1.33 - if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+wheadpt*0.5 - write(notexq(14:17),'(f4.1)')aftshft - call addstr(notexq(1:17)//'pt}'//sq//'bsk',24,soutq,lsout) - end if -c -c Start the beam -c - notexq = sq//'ib' - do 119 ing = 2 , mg - notexq = notexq(1:ing+1)//'b' -119 continue - if (upg(ig)) then - notexq = notexq(1:mg+2)//'u' - else - notexq = notexq(1:mg+2)//'l' - end if - notexq = notexq(1:mg+3)//'0' -c -c Get starting note for beam -c - call notefq(noteq,lnoten,nolev1,ncm) - call addstr(notexq(1:mg+4)//noteq(1:lnoten), - * mg+4+lnoten,soutq,lsout) -c -c Put in the slope -c - if (islope .ge. 0) then - call addstr(chax(48+islope),1,soutq,lsout) - else - call addstr('{-'//chax(48-islope)//'}',4,soutq,lsout) - end if -c -c Start a slur on multiple fore-grace -c - if (slurg(ig) .and. .not.isgaft .and. .not.iswaft) then - call notefq(noteq,lnoten,nolevg(ngs),ncm) - if (fontslur) then - if (upg(ig)) then - call addstr(sq//'islurd',7,soutq,lsout) - else - call addstr(sq//'isluru',7,soutq,lsout) - end if - else -c -c Need a tweak for postscript slur -c - if (upg(ig)) then - call addstr(sq//'isd',4,soutq,lsout) - else - call addstr(sq//'isu',4,soutq,lsout) - end if - end if -c -c Print 11-ndxslur -c - if (23-ndxslur .lt. 10) then - call addstr(chax(71-ndxslur)//noteq(1:lnoten),1+lnoten, - * soutq,lsout) - else if (23-ndxslur .lt. 2) then - call addstr('{1'//chax(61-ndxslur)//'}'//noteq(1:lnoten), - * 4+lnoten,soutq,lsout) - else - call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten), - * 4+lnoten,soutq,lsout) - end if -c -c Put in tweak for postscript slur -c - if (.not.fontslur) call addstr('{-.3}',5,soutq,lsout) - end if -c -c Put in first note. Call notefq again in case octave changed -c - call notefq(noteq,lnoten,nolevg(ngs),ncm) - if (naccg(ngs) .eq. 0) then - notexq = sq//'zqb0'//noteq(1:lnoten) - lnote = 5+lnoten - else - if (lnoten .eq. 1) call addblank(noteq,lnoten) - call accsym(naccg(ngs),acsymq,lacc) - notexq = sq//'big'//acsymq(1:lacc)//noteq(1:lnoten) - lnote = 4+lacc+lnoten - call notefq(noteq,lnoten,nolevg(ngs),ncm) - notexq =notexq(1:lnote)//sq//'zqb0'//noteq(1:lnoten) - lnote = lnote+5+lnoten - end if - call addstr(notexq,lnote,soutq,lsout) - do 127 ing = ngs+1 , ngs+nng(ig)-1 -c -c Skip -c - ptoff = wheadpt1*emgfac - if (naccg(ing).gt.0) ptoff = ptoff+wheadpt1*acgfac - if (isgaft .and. .not.iswaft) aftshft = aftshft+ptoff - notexq = sq//'off{' - write(notexq(6:8),'(f3.1)')ptoff - if (normsp) finalshift = finalshift-ptoff - call addstr(notexq(1:8)//'pt}',11,soutq,lsout) - if (ing .eq. ngs+nng(ig)-1) then -c -c Terminate beam if needed -c - if (upg(ig)) then - call addstr(sq//'tbu0',5,soutq,lsout) - else - call addstr(sq//'tbl0',5,soutq,lsout) - end if -c -c Terminate after slur if needed -c - if ((isgaft.or.iswaft) .and. slurg(ig)) then -c if (iswaft) ndxslur = igetbits(ipl,4,23) - if (iswaft) ndxslur = igetbits(ipl,5,23) - call notefq(noteq,lnoten,nolevg(ing),ncm) - call addstr(sq//'tslur',6,soutq,lsout) -c -c Print 11-ndxslur -cc Print 23-ndxslur -c - if (23-ndxslur .lt. 10) then - call addstr(chax(71-ndxslur)//noteq(1:lnoten), - * 1+lnoten,soutq,lsout) - else if (23-ndxslur .lt. 20) then - call addstr('{2'//chax(61-ndxslur)//'}' - * //noteq(1:lnoten),4+lnoten,soutq,lsout) - else - call addstr('{1'//chax(51-ndxslur)//'}' - * //noteq(1:lnoten),4+lnoten,soutq,lsout) - end if -c -c Stop slur terminator after exit from this subroutine -c - listslur = ibclr(listslur,ndxslur) - slurg(ig) = .false. - end if - end if -c -c Accidental if needed -c - if (naccg(ing).gt.0) then - call notefq(noteq,lnoten,nolevg(ing),ncm) - if (lnoten .eq. 1) call addblank(noteq,lnoten) - call accsym(naccg(ing),acsymq,lacc) - call addstr(sq//'big'//acsymq(1:lacc) - * //noteq(1:lnoten),4+lacc+lnoten,soutq,lsout) - end if -c -c Put in the (beamed) grace note -c - call notefq(noteq,lnoten,nolevg(ing),ncm) - call addstr(sq//'zqb0'//noteq(1:lnoten),5+lnoten, - * soutq,lsout) -127 continue -c -c Terminate the grace -c -c notexq = sq//'normalnotesize'//sq//'off{' -c lnote = 20 -c notexq = '}'//sq//'off{' -c lnote = 6 - notexq = sq//'off{' - lnote = 5 - ptoff = wheadpt*emgfac - if (iand(nacc,3).gt.0 .and. .not.btest(nacc,17)) - * ptoff = ptoff+wheadpt*accfac - if (isgaft .and. .not.iswaft) then - notexq = notexq(1:5)//'-' - lnote = 6 - ptoff = aftshft - end if - if (normsp) ptoff = finalshift - if (ptoff .lt. 9.95) then - write(notexq(lnote+1:lnote+3),'(f3.1)')ptoff - lnote = lnote+3 - else if (ptoff .lt. 99.95) then - write(notexq(lnote+1:lnote+4),'(f4.1)')ptoff - lnote = lnote+4 - else - write(notexq(lnote+1:lnote+5),'(f5.1)')ptoff - lnote = lnote+5 - end if - call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout) - if (isgaft.and..not.iswaft) call addstr(sq//'sk',3,soutq,lsout) - call addstr(sq//'resetsize',10,soutq,lsout) - end if - return - end - subroutine dopsslur(nolev,isdat1,isdat2,isdat3,isdat4,nsdat,ip, - * iv,kv,nv,beamon,ncm,soutq,lsout,ulq,islur, - * ipl,iornq,islhgt,tno,nacc) -c -c Called once per main note. -c 12 May 2002 Create this subroutine to isolate postscript slurs/ties. -c Always set \Nosluradjust\Notieadjust -c - parameter (nm=24,mv=24576) - integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - common /comsln/ is1n1,is2n1,irzbnd,isnx - character*1 ulq,slurudq,udfq,udqq,chax - character*79 notexq - character*8 noteq - character*80 soutq - logical upslur,beamon,btest,stemup,iscrd, - * settie,fontslur,pstie,WrotePsslurDefaults - logical slmon,dbltie - common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), - * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, - * slmon(0:nm),dbltie - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi -c -c Bits in isdat1: -c 13-17 iv -c 3-10 ip -c 11 start/stop switch -c 12 kv-1 -c 19-25 ichar(code$) -c 26 force direction? -c 27 forced dir'n = up if on, set in sslur; also -c final direction, set in doslur when beam is started, used on term. -c 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term. -c 18 int(ndxslur/16), ditto. So this allows ndxslur>15. -c -c Bits in isdat2 -c 0 Chord switch. Not set on main note. -c 1-2 left/right notehead shift. Set only for chord note. -c 3 tie positioning -c 4 dotted flag -c 6-11 voff1 1-63 => -31...+31 -c 12-18 hoff1 1-127 => -6.3...+6.3 -c 19-25 nolev -c 26 \sluradjust (p+s) -c 27 \nosluradjust (p-s) -c 28 \tieadjust (p+t) -c 29 \notieadjust (p-t) -c -c Bits in isdat3: Only used for slur endings -c 0 set if midslur (at least one argument) -c 1 set if curve (2 more args) -c 2-7 32+first arg (height correction) (1st arg may be negative) -c 8-10 second arg (initial slope) -c 11-13 third arg (closing slope) -c 14-21 tie level for use in LineBreakTies -c 22-29 ncm for use in LineBreakTies -c -c Bits in isdat4 Only used for linebreak slurs -c 0-5 Linebreak seg 1 voff 1-63 => -31...+31 -c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 -c 16-21 Linebreak seg 2 voff 1-63 => -31...+31 -c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 -c -c In listslur bit ib is on if slur index ib is in use, ib=0-13. -c ndxslur = slur index -c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, -c s-slur is blank (idcode=32), t-slur is idcode=1. -c ivoff is user-defined shift or shift due to . or _ , or chord adjustment. -c Ivoff will be set for ./_ only if no user-defined shift is specified. -c If highest note has upslur, save slur height in islhgt in case -c ornament must be moved. -c - islhgt = 0 - if (beamon) then - stemup = ulq .eq. 'u' - else if (nvmx(iv) .eq. 2) then - if (.not.btest(islur,30)) then -c -c Single note, 2 lines of music, stem direction not forced -c - stemup = ivx .gt. nv - else - stemup = btest(islur,17) - end if - else - stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u' - end if - iscrd = btest(ipl,10) - if (ismidi) then - settie = .false. - dbltie = .false. - end if - do 1 isdat = 1 , nsdat - isdata = isdat1(isdat) - if (iv .eq. igetbits(isdata,5,13) .and. - * ip .eq. igetbits(isdata,8,3) .and. - * kv .eq. igetbits(isdata,1,12)+1) then -c -c Since iv and kv match, ivx will be correct -c - idcode = igetbits(isdata,7,19) - ivoff = igetbits(isdat2(isdat),6,6)-32 - ihoff = igetbits(isdat2(isdat),7,12)-64 - iupdn = 0 - slurudq = 'd' - nolevs = igetbits(isdat2(isdat),7,19) - pstie = btest(isdat2(isdat),3) .or. idcode.eq.1 - if (btest(isdata,11)) then -c -c Turnon -c -c if (nolevs.eq.0 .or. nolevs.gt.60) then -cc -cc Note was a rest, cannot start slur on rest. -cc -c print* -c call printl('Cannot start slur on a rest') -c call stop1() -c nolevs = ncm+5 -c end if -c -c Get slur direction -c - if (btest(isdata,26)) then -c -c Force slur direction -c - if (btest(isdata,27)) slurudq = 'u' - else if (nvmx(iv) .eq. 1) then -c -c Only one voice per line -c - if (.not.beamon) then -c -c Separate note. -c - slurudq = udfq(nolev,ncm) - else -c -c In a beam -c - if (ulq .ne. 'u') slurudq = 'u' - end if - if (iscrd) then - if (nolevs .gt. ncm) then - slurudq = 'u' - else - slurudq = 'd' - end if - end if - else -c -c Two voices per line. Get default -c - if (ivx .gt. nv) slurudq = 'u' -c -c Upper voice of the two, so up slur -c - end if -c -c Set level for slur starting on rest -c - if (nolevs.eq.0 .or. nolevs.gt.60) then - if (slurudq .eq. 'u') then - nolevs = ncm+2 - else - nolevs = ncm-2 - end if - end if -c -c Save up/down-ness for use at termination -c - if (slurudq .eq. 'u') isdata = ibset(isdata,27) -c -c End of section for setting slur direction, still in "Turnon" if-block. -c - if (btest(iornq,11).or.btest(iornq,12)) then -c -c Raise or lower slur by one unit provided . or _ is on same side as slur -c - ivoffinc = 0 - if ((stemup .and. slurudq.eq.'d') .or. - * (.not.stemup .and. slurudq.eq.'u')) then -c -c Must move the slur for _ or . -c - if (stemup) then - ivoffinc = -1 - else - ivoffinc = 1 - end if - if (((stemup .and. nolev.ge.ncm-2) .or. - * (.not.stemup .and. nolev.le.ncm+2)) .and. - * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc - ivoff = ivoff+ivoffinc - end if - end if - if (listslur .eq. 16777215) then - print* - print*,'You1 defined the twentyfifth slur, one too many!' - write(15,'(/,a)') - * 'You defined the twentyfifth slur, one too many!' - call stop1() - end if -c -c Get index of next slur not in use, starting from 12 down -c - ndxslur = log2(16777215-listslur) -c write(*,'()') -c write(*,'(2i4,2x,B24)')ivx,ndxslur,listslur -c -c Record slur index -c - listslur = ibset(listslur,ndxslur) -c write(*,'(10x,B24)')listslur -c -c Save for use on termination -c -c call setbits(isdata,4,28,ndxslur) -c 080531 Allow >16 slurs - call setbits(isdata,4,28,mod(ndxslur,16)) - call setbits(isdata,1,18,ndxslur/16) -c -c Shift for stem? -c - if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) then - if (.not.pstie) then - ihoff = ihoff+8 - else - ihoff = ihoff+2 - end if - end if - if (iscrd) then -c -c Additional horiz shifts for h-shifted noteheads? -c - if (btest(isdat2(isdat),1)) then -c -c Slur start on left-shifted chord notehead. ASSUME downstem. -c - if (nolevs.eq.minlev .and. slurudq.eq.'d') then - ihoff = ihoff-2 - else - ihoff = ihoff-10 - end if - else if (btest(isdat2(isdat),2)) then -c -c Right shifted chord notehead. ASSUME upstem. -c - if (nolevs.eq.maxlev .and. slurudq.eq.'u') then - ihoff = ihoff+2 - else - ihoff = ihoff+10 - end if - end if - end if - notexq = chax(92) - lnote = 1 -c -c Check for local adjustment default changes -c - if (btest(isdat2(isdat),26)) then - notexq = chax(92)//'sluradjust'//chax(92) - lnote = 12 - else if (btest(isdat2(isdat),27)) then - notexq = chax(92)//'nosluradjust'//chax(92) - lnote = 14 - else if (btest(isdat2(isdat),28)) then - notexq = chax(92)//'tieadjust'//chax(92) - lnote = 11 - else if (btest(isdat2(isdat),29)) then - notexq = chax(92)//'notieadjust'//chax(92) - lnote = 13 - end if - if (ihoff .eq. 0) then -c -c Write stuff for non-shifted start -c - notexq = notexq(1:lnote)//'islur'//slurudq - lnote = lnote+6 - else - notexq = notexq(1:lnote)//'is'//slurudq - lnote = lnote+3 - end if -c -c Prepend postscript tie switch -c - if (pstie) then - notexq = chax(92)//'tieforis'//slurudq//notexq(1:lnote) - lnote = lnote+10 - end if - if (btest(isdat2(isdat),4)) then -c -c Dotted slur -c -c noteq = notexq -c notexq = chax(92)//'dotted'//noteq - notexq = chax(92)//'dotted'//notexq(1:lnote) - lnote = lnote+7 - end if -c -c Add slur index to string -cc Print 11-ndxslur -c Print 23-ndxslur -c -c if (11-ndxslur .lt. 10) then - if (23-ndxslur .lt. 10) then -c -c 5/25/08 Allow 24 slurs -c -c notexq = notexq(1:lnote)//chax(59-ndxslur) - notexq = notexq(1:lnote)//chax(71-ndxslur) - lnote = lnote+1 - else if (23-ndxslur .lt. 20) then -c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' - notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' - lnote = lnote+4 - else - notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' - lnote = lnote+4 - end if -c -c Add note name to string -c -c call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) - islhgt = nolevs+iupdn+ivoff - call notefq(noteq,lnoten,islhgt,ncm) - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+lnoten -c -c Store height and staff mid level for use with LineBreakTies -c - call setbits(isdat3(isdat),8,14,islhgt) - call setbits(isdat3(isdat),8,22,ncm) -c -c Save height (for ornament and barnobox interference) if topmost slur is up -c - if (slurudq.eq.'u' .and. - * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then - islhgt = nolevs+iupdn+ivoff -c -c Save height & idcode if top voice and slur start -c - if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then - is1n1 = islhgt - is2n1 = idcode - end if - end if - if (ihoff .ne. 0.) then - shift = ihoff*0.1 - notexq = notexq(1:lnote)//'{' - lnote = lnote+1 - lform = lfmt1(shift) - write(notexq(lnote+1:lnote+lform),'(f'// - * chax(48+lform)//'.1)') shift - lnote = lnote+lform - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - end if - call addstr(notexq,lnote,soutq,lsout) -c -c Zero out ip1 to avoid problems if slur goes to next input blk. -c - call setbits(isdata,8,3,0) -c -c Set slur-on data for midi. Only treat null-index slurs and ps ties for now. -c - if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then -c levson(midchan(iv,kv)) = nolev - levson(midchan(iv,kv)) = nolevs - if (settie) dbltie = .true. -c -c Only way settie=T is if we just set a tie ending. So there's also a slur -c start here, so set a flag telling addmidi not to zero out levson -c - end if - else -c -c Slur is ending. Back thru list to find starting slur -c - do 3 j = isdat-1 , 1 , -1 - if (iv.eq.igetbits(isdat1(j),5,13) .and. - * kv.eq.igetbits(isdat1(j),1,12)+1) then - if (idcode .eq. igetbits(isdat1(j),7,19)) then - ndxslur = igetbits(isdat1(j),4,28) -c -c 080531 Allow >16 slurs -c - * +16*igetbits(isdat1(j),1,18) - if (btest(isdat1(j),27)) slurudq = 'u' - go to 4 - end if - end if -3 continue - print*,'Bad place in doslur' - call stop1() -4 continue -c -c Bugfix 070901 for slur ending on rest in 2-voice staff -c -c if (nolevs.eq.0 .or. nolevs.gt.60) then - if (nolevs.le.2 .or. nolevs.gt.60) then -c -c Ending is on a rest, reset nolevs to default starting height -c - nolevs = igetbits(isdat2(j),7,19) - end if - if (btest(isdat3(isdat),0) .or. btest(isdat3(j),0)) then -c -c Deal with \curve or \midslur. isdat is ending, j is start. -c - if (btest(isdat3(isdat),0)) then - imid = igetbits(isdat3(isdat),6,2)-32 - else - imid = igetbits(isdat3(j),6,2)-32 - end if -c -c Postscript slurs, and \midslur adjustment is needed. Invoke macro -c (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping: -c Abs(imid) Postscript slur type -c 1 f -c 2-3 default -c 4 h -c 5 H -c 6+ HH -c - call addstr(chax(92)//'psforts'// - * chax(48+min(abs(imid),6)),9,soutq,lsout) - end if -c -c Shift slur ending for stem on any note? -c - if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) then - if (.not.pstie) then - ihoff = ihoff-8 - else - ihoff = ihoff-3 - end if - end if - if (iscrd) then -c -c Shift termination for shifted notehead? -c - if (btest(isdat2(isdat),1)) then -c -c Left-shifted chord notehead. ASSUME downstem. -c - if (nolevs.eq.minlev .and. slurudq.eq.'d') then - ihoff = ihoff-2 - else - ihoff = ihoff-10 - end if - else if (btest(isdat2(isdat),2)) then -c -c Right shifted chord notehead. ASSUME upstem. -c - if (nolevs.eq.maxlev .and. slurudq.eq.'u') then - ihoff = ihoff+2 - else - ihoff = ihoff+10 - end if - end if - end if - if (ihoff .eq. 0) then - notexq = chax(92)//'tslur' - lnote = 6 - else -c -c Shift needed -c - notexq = chax(92)//'ts' - lnote = 3 - end if -c -c Switch to postscript tie -c - if (pstie) then - notexq = chax(92)//'tieforts'//notexq(1:lnote) - lnote = lnote+9 - end if -c -c Print 13-ndxslur -c 5/25/08 Allow 14 slurs -c - if (23-ndxslur .lt. 10) then - notexq = notexq(1:lnote)//chax(71-ndxslur) - lnote = lnote+1 - else if (23-ndxslur .lt. 20) then - notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' - lnote = lnote+4 - else - notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' - lnote = lnote+4 - end if - if (btest(iornq,11).or.btest(iornq,12)) then -c -c Raise or lower slur by one unit provided . or _ is on same side as slur -c - ivoffinc = 0 - if ((stemup .and. slurudq.eq.'d') .or. - * (.not.stemup .and. slurudq.eq.'u')) then - if (stemup) then - ivoffinc = -1 - else - ivoffinc = 1 - end if - if (((stemup .and. nolev.ge.ncm-2) .or. - * (.not.stemup .and. nolev.le.ncm+2)) .and. - * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc - end if - ivoff = ivoff+ivoffinc - end if - call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) - if (slurudq.eq.'u' .and. - * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then - islhgt = nolevs+iupdn+ivoff -c -c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. -c - if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then - if (idcode .eq. is2n1) is1n1=0 - end if - end if - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+lnoten - if (ihoff .ne. 0) then - shift = ihoff*0.1 - notexq = notexq(1:lnote)//'{' - lnote = lnote+1 - lform = lfmt1(shift) - write(notexq(lnote+1:lnote+lform), - * '(f'//chax(48+lform)//'.1)')shift - lnote = lnote+lform - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - end if - call addstr(notexq,lnote,soutq,lsout) -c -c Clear the bit from list of slurs in use -c - listslur = ibclr(listslur,ndxslur) -c -c Zero out the entire strings for start and stop -c - isdata = 0 - isdat2(isdat) = 0 - isdat3(isdat) = 0 - isdat4(isdat) = 0 - isdat1(j) = 0 - isdat2(j) = 0 - isdat3(j) = 0 - isdat4(j) = 0 -c -c Set midi info for slur ending -c - if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then - icm = midchan(iv,kv) - if (slmon(icm)) then - if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then -c -c There is a tie here. NB!!! assumed no accidental on 2nd member of tie. -c - levsoff(icm) = nolevs - settie = .true. - else - levsoff(icm) = 0 - levson(icm) = 0 - slmon(icm) = .false. - end if - end if - end if - end if - isdat1(isdat) = isdata - end if -1 continue -c -c Clear and collapse the slur data list -c - numdrop = 0 - do 2 isdat = 1 , nsdat - if (isdat1(isdat) .eq. 0) then - numdrop = numdrop+1 - else if (numdrop .gt. 0) then - isdat1(isdat-numdrop) = isdat1(isdat) - isdat2(isdat-numdrop) = isdat2(isdat) - isdat3(isdat-numdrop) = isdat3(isdat) - isdat4(isdat-numdrop) = isdat4(isdat) - isdat1(isdat) = 0 - isdat2(isdat) = 0 - isdat3(isdat) = 0 - isdat4(isdat) = 0 - end if -2 continue - nsdat = nsdat-numdrop -c call report(nsdat,isdat1,isdat2) - return - end - subroutine doslur(nolev,isdat1,isdat2,isdat3,nsdat,ip,iv,kv,nv, - * beamon,ncm,soutq,lsout,ulq,islur,ipl,iornq,islhgt,tno,nacc) -c -c Called once per main note. (5/26/02) for non-ps slurs only -c - parameter (nm=24,mv=24576) - integer*4 isdat1(202),isdat2(202),isdat3(202) - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - common /comsln/ is1n1,is2n1,irzbnd,isnx - character*1 ulq,slurudq,udfq,udqq,chax - character*79 notexq - character*8 noteq - character*80 soutq - logical upslur,beamon,btest,stemup,iscrd,sfound,tfound,tmove, - * settie,fontslur,WrotePsslurDefaults - logical slmon,dbltie - common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), - * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, - * slmon(0:nm),dbltie - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi -c -c Bits in isdat1: -c 13-17 iv -c 3-10 ip -c 11 start/stop switch -c 12 kv-1 -c 19-25 ichar(code$) -c 26 force direction? -c 27 forced dir'n = up if on, set in sslur; also -c final direction, set in doslur when beam is started, used on term. -c 28-31 ndxslur, set in doslur when beam is started, used on term. -c -c Bits in isdat2 -c 0 Chord switch. Not set on main note. -c 1-2 left/right notehead shift. Set only for chord note. -c 3 tie positioning -c 4 dotted flag -c 6-11 voff1 1-63 => -31...+31 -c 12-18 hoff1 1-127 => -6.3...+6.3 -c 19-25 nolev -c -c Bits in isdat3: Only used for slur endings -c 0 set if midslur (at least one argument) -c 1 set if curve (2 more args) -c 2-7 32+first arg (height correction) (1st arg may be negative) -c 8-10 second arg (initial slope) -c 11-13 third arg (closing slope) -c -c In listslur bit ib is on if slur index ib is in use, ib=0-23. -c ndxslur = slur index -c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, -c s-slur is blank (idcode=32), t-slur is idcode=1. -c ivoff is user-defined shift or shift due to . or _ , or chord adjustment. -c Ivoff will be set for ./_ only if no user-defined shift is specified. -c If highest note has upslur, save slur height in islhgt in case -c ornament must be moved. -c - islhgt = 0 - if (beamon) then - stemup = ulq .eq. 'u' - else if (nvmx(iv) .eq. 2) then - if (.not.btest(islur,30)) then -c -c Single note, 2 lines of music, stem direction not forced -c - stemup = ivx .gt. nv - else - stemup = btest(islur,17) - end if - else - stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u' - end if - iscrd = btest(ipl,10) - if (btest(islur,1)) then -c -c 't'-slur (idcode=1) somewhere on this note. Find it, check height against -c 's'-slur (idcode=32) -c - sfound = .false. - tfound = .false. - tmove = .false. - do 5 isdat = 1 , nsdat - if (iv .eq. igetbits(isdat1(isdat),5,13) .and. - * ip .eq. igetbits(isdat1(isdat),8,3) .and. - * kv .eq. igetbits(isdat1(isdat),1,12)+1) then - if (.not.tfound) then - tfound = igetbits(isdat1(isdat),7,19).eq.1 - if (tfound) then - nolevt = igetbits(isdat2(isdat),7,19) - isdatt = isdat - if (sfound) go to 6 - end if - end if - if (.not.sfound) then - sfound = igetbits(isdat1(isdat),7,19).eq.32 - if (sfound) then - nolevs = igetbits(isdat2(isdat),7,19) - isdats = isdat - if (tfound) go to 6 - end if - end if - end if -5 continue -c -c Will come thru here if there is a t with no s, so comment out the following -c print*,'Did not find s+t-slurs in doslur' -c -6 continue - if (sfound .and. tfound) - * tmove = nolevs.eq.nolevt .and. -c -c Check if 2 starts or two stops -c - * ((btest(isdat1(isdats),11).and.btest(isdat1(isdatt),11)) .or. - * (.not.btest(isdat1(isdats),11).and. - * .not.btest(isdat1(isdatt),11)) ) -c -c This is a flag for later changing slur level, after we know slur dir'n. -c - end if - if (ismidi) then - settie = .false. - dbltie = .false. - end if - do 1 isdat = 1 , nsdat - isdata = isdat1(isdat) - if (iv .eq. igetbits(isdata,5,13) .and. - * ip .eq. igetbits(isdata,8,3) .and. - * kv .eq. igetbits(isdata,1,12)+1) then -c -c Since iv and kv match, ivx will be correct -c - idcode = igetbits(isdata,7,19) - ivoff = igetbits(isdat2(isdat),6,6)-32 - ihoff = igetbits(isdat2(isdat),7,12)-64 - iupdn = 0 - slurudq = 'd' - nolevs = igetbits(isdat2(isdat),7,19) - if (btest(isdata,11)) then -c -c Turnon, -c - if (nolevs.eq.0 .or. nolevs.gt.60) then -c -c Note was a rest, cannot start slur on rest. -c - print* - call printl('Cannot start slur on a rest') - call stop1() - end if -c -c Get slur direction -c - if (btest(isdata,26)) then -c -c Force slur direction -c - if (btest(isdata,27)) slurudq = 'u' - else if (nvmx(iv) .eq. 1) then -c -c Only one voice per line -c - if (.not.beamon) then -c -c Separate note. -c - slurudq = udfq(nolev,ncm) - else -c -c In a beam -c - if (ulq .ne. 'u') slurudq = 'u' - end if - if (iscrd) then - if (nolevs .gt. ncm) then - slurudq = 'u' - else - slurudq = 'd' - end if - end if - else -c -c Two voices per line. Get default -c - if (ivx .gt. nv) slurudq = 'u' -c -c Upper voice of the two, so up slur -c - end if -c -c Save up/down-ness for use at termination -c - if (slurudq .eq. 'u') isdata = ibset(isdata,27) -c -c End of section for setting slur direction, still in "Turnon" if-block. -c - if (idcode.eq.1 .and. tmove) then - iupdn = 1 - if (slurudq .eq. 'd') iupdn = -1 - end if - if (btest(iornq,11).or.btest(iornq,12)) then -c -c Raise or lower slur by one unit provided . or _ is on same side as slur -c - ivoffinc = 0 - if ((stemup .and. slurudq.eq.'d') .or. - * (.not.stemup .and. slurudq.eq.'u')) then -c -c Must move the slur for _ or . -c - if (stemup) then - ivoffinc = -1 - else - ivoffinc = 1 - end if - if (((stemup .and. nolev.ge.ncm-2) .or. - * (.not.stemup .and. nolev.le.ncm+2)) .and. - * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc - ivoff = ivoff+ivoffinc - end if - end if - if (listslur .eq. 16777215) then - print* - print*,'You1 defined the twenty-fifth slur, one too many!' - write(15,'(/,a)') - * 'You2 defined the twenty-fifth slur, one too many!' - call stop1() - end if -c -c Get index of next slur not in use, starting from ? down -c - ndxslur = log2(16777215-listslur) -c -c Record slur index -c - listslur = ibset(listslur,ndxslur) -c -c Save for use on termination -c -c call setbits(isdata,4,28,ndxslur) -c 080531 Allow >16 slurs - call setbits(isdata,4,28,mod(ndxslur,16)) - call setbits(isdata,1,18,ndxslur/16) -c -c Shift for stem? -c - if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) - * ihoff = ihoff+8 - if (btest(isdat2(isdat),3)) then -c -c Tie spacing, (slur start) -c - if (slurudq.eq.'d') then - ivoff = ivoff+1 - ihoff = ihoff+8 - else if (slurudq.eq.'u') then - ivoff = ivoff-1 - if (.not.(stemup.and.tno.lt.63.)) ihoff = ihoff+8 -c -c (already shifted if (stemup.and.tno.gt.63.) and slurudq='u') -c - end if - end if - if (iscrd) then -c -c Additional horiz shifts for h-shifted noteheads? -c - if (btest(isdat2(isdat),1)) then -c -c Slur start on left-shifted chord notehead. ASSUME downstem. -c - if (nolevs.eq.minlev .and. slurudq.eq.'d') then - ihoff = ihoff-2 - else - ihoff = ihoff-10 - end if - else if (btest(isdat2(isdat),2)) then -c -c Right shifted chord notehead. ASSUME upstem. -c - if (nolevs.eq.maxlev .and. slurudq.eq.'u') then - ihoff = ihoff+2 - else - ihoff = ihoff+10 - end if - end if - end if - if (ihoff .eq. 0) then -c -c Write stuff for non-shifted start -c - notexq = chax(92)//'islur'//slurudq - lnote = 7 - else - notexq = chax(92)//'is'//slurudq - lnote = 4 - end if - if (btest(isdat2(isdat),4)) then -c -c Dotted slur -c - noteq = notexq - notexq = chax(92)//'dotted'//noteq - lnote = lnote+7 - end if -c -c Add slur index to string -cc Print 11-ndxslur -c Print 23-ndxslur -c -c if (11-ndxslur .lt. 10) then - if (23-ndxslur .lt. 10) then -c -c 5/25/08 Allow 24 slurs -c -c notexq = notexq(1:lnote)//chax(59-ndxslur) - notexq = notexq(1:lnote)//chax(71-ndxslur) - lnote = lnote+1 - else if (23-ndxslur .lt. 20) then -c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' - notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' - lnote = lnote+4 - else - notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' - lnote = lnote+4 - end if -c -c Add note name to string -c - call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+lnoten -c -c Save height (for ornament and barnobox interference) if topmost slur is up -c - if (slurudq.eq.'u' .and. - * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then - islhgt = nolevs+iupdn+ivoff -c -c Save height & idcode if top voice and slur start -c - if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then - is1n1 = islhgt - is2n1 = idcode - end if - end if - if (ihoff .ne. 0.) then - shift = ihoff*0.1 - notexq = notexq(1:lnote)//'{' - lnote = lnote+1 - lform = lfmt1(shift) - write(notexq(lnote+1:lnote+lform),'(f'// - * chax(48+lform)//'.1)') shift - lnote = lnote+lform - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - end if - call addstr(notexq,lnote,soutq,lsout) -c -c Zero out ip1 to avoid problems if slur goes to next input blk. -c - call setbits(isdata,8,3,0) -c -c Set slur-on data for midi. Only treat null-index slurs and ps ties for now. -c - if (ismidi .and. idcode.eq.32) then - levson(midchan(iv,kv)) = nolevs - if (settie) dbltie = .true. -c -c Only way settie=T is if we just set a tie ending. So there's also a slur -c start here, so set a flag telling addmidi not to zero out levson -c - end if - else -c -c Slur is ending. Back thru list to find starting slur -c - do 3 j = isdat-1 , 1 , -1 - if (iv.eq.igetbits(isdat1(j),5,13) .and. - * kv.eq.igetbits(isdat1(j),1,12)+1) then - if (idcode .eq. igetbits(isdat1(j),7,19)) then - ndxslur = igetbits(isdat1(j),4,28) -c -c 080531 Allow >16 slurs -c - * +16*igetbits(isdat1(j),1,18) - if (btest(isdat1(j),27)) slurudq = 'u' - go to 4 - end if - end if -3 continue - print*,'Bad place in doslur' - call stop1() -4 continue - if (nolevs.eq.0 .or. nolevs.gt.60) then -c -c Ending is on a rest, reset nolevs to default starting height -c - nolevs = igetbits(isdat2(j),7,19) - end if - if (btest(isdat3(isdat),0)) then -c -c Deal with \curve or \midslur -c - imid = igetbits(isdat3(isdat),6,2)-32 -c -c Remember, only dealing with non-ps slurs -c -c Who knows where the following line came from. Removed it 6/30/02 to -c restore behavior of non-ps slurs to old way -c if (slurudq .eq. 'd') imid = -imid -c 3/8/03 added the following -c - if (slurudq .eq. 'd') imid = -abs(imid) -c - if (btest(isdat3(isdat),1)) then - notexq = chax(92)//'curve' - lnote = 6 - else - notexq = chax(92)//'midslur' - lnote = 8 - end if - if (imid.lt.0 .or. imid.gt.9) then -c -c Need brackets -c - notexq = notexq(1:lnote)//'{' - lnote = lnote+1 - if (imid .lt. -9) then - write(notexq(lnote+1:lnote+3),'(i3)')imid - lnote = lnote+3 - else if (imid.lt.0 .or. imid.gt.9) then - write(notexq(lnote+1:lnote+2),'(i2)')imid - lnote = lnote+2 - else - write(notexq(lnote+1:lnote+1),'(i1)')imid - lnote = lnote+1 - end if - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - else -c -c 1=<imid=<9, no brackets -c - notexq = notexq(1:lnote)//char(48+imid) - lnote = lnote+1 - end if - if (btest(isdat3(isdat),1)) then -c -c \curve; 3 args -c - notexq = notexq(1:lnote) - * //char(48+igetbits(isdat3(isdat),3,8)) - notexq = notexq(1:lnote+1) - * //char(48+igetbits(isdat3(isdat),3,11)) - lnote = lnote+2 - end if - call addstr(notexq,lnote,soutq,lsout) - end if -c -c Shift slur ending for stem on any note? -c - if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) - * ihoff = ihoff-8 - if (btest(isdat2(isdat),3)) then -c -c Shift ending for tie spacing -c - if (slurudq .eq. 'u') then - ihoff = ihoff-8 - ivoff = ivoff-1 - else if (slurudq .eq. 'd') then - ivoff = ivoff+1 - if (stemup.or. tno.gt.63.) ihoff = ihoff-8 - end if - end if - if (iscrd) then -c -c Shift termination for shifted notehead? -c - if (btest(isdat2(isdat),1)) then -c -c Left-shifted chord notehead. ASSUME downstem. -c - if (nolevs.eq.minlev .and. slurudq.eq.'d') then - ihoff = ihoff-2 - else - ihoff = ihoff-10 - end if - else if (btest(isdat2(isdat),2)) then -c -c Right shifted chord notehead. ASSUME upstem. -c - if (nolevs.eq.maxlev .and. slurudq.eq.'u') then - ihoff = ihoff+2 - else - ihoff = ihoff+10 - end if - end if - end if - if (ihoff .eq. 0) then - notexq = chax(92)//'tslur' - lnote = 6 - else -c -c Shift needed -c - notexq = chax(92)//'ts' - lnote = 3 - end if -c -c Print 23-ndxslur -c 5/25/08 Allow 14 slurs (???????????) -c - if (23-ndxslur .lt. 10) then - notexq = notexq(1:lnote)//chax(71-ndxslur) - lnote = lnote+1 - else if (23-ndxslur .lt. 20) then - notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' - lnote = lnote+4 - else - notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' - lnote = lnote+4 - end if - if (btest(iornq,11).or.btest(iornq,12)) then -c -c Raise or lower slur by one unit provided . or _ is on same side as slur -c - ivoffinc = 0 - if ((stemup .and. slurudq.eq.'d') .or. - * (.not.stemup .and. slurudq.eq.'u')) then - if (stemup) then - ivoffinc = -1 - else - ivoffinc = 1 - end if - if (((stemup .and. nolev.ge.ncm-2) .or. - * (.not.stemup .and. nolev.le.ncm+2)) .and. - * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc - end if - ivoff = ivoff+ivoffinc - end if - if (idcode.eq.1 .and. tmove) then -c -c t-slur height adjustment -c - iupdn = 1 - if (slurudq .eq. 'd') iupdn = -1 - end if - call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) - if (slurudq.eq.'u' .and. - * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then - islhgt = nolevs+iupdn+ivoff -c -c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. -c - if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then - if (idcode .eq. is2n1) is1n1=0 - end if - end if - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+lnoten - if (ihoff .ne. 0) then - shift = ihoff*0.1 - notexq = notexq(1:lnote)//'{' - lnote = lnote+1 - lform = lfmt1(shift) - write(notexq(lnote+1:lnote+lform), - * '(f'//chax(48+lform)//'.1)')shift - lnote = lnote+lform - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - end if - call addstr(notexq,lnote,soutq,lsout) -c -c Clear the bit from list of slurs in use -c - listslur = ibclr(listslur,ndxslur) -c -c Zero out the entire strings for start and stop -c - isdata = 0 - isdat2(isdat) = 0 - isdat1(j) = 0 - isdat2(j) = 0 - isdat3(isdat) = 0 -c -c Set midi info for slur ending -c - if (ismidi .and. idcode.eq.32) then - icm = midchan(iv,kv) - if (slmon(icm)) then - if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then -c -c There is a tie here. NB!!! assumed no accidental on 2nd member of tie. -c - levsoff(icm) = nolevs - settie = .true. - else - levsoff(icm) = 0 - levson(icm) = 0 - slmon(icm) = .false. - end if - end if - end if - end if - isdat1(isdat) = isdata - end if -1 continue -c -c Clear and collapse the slur data list -c - numdrop = 0 - do 2 isdat = 1 , nsdat - if (isdat1(isdat) .eq. 0) then - numdrop = numdrop+1 - else if (numdrop .gt. 0) then - isdat1(isdat-numdrop) = isdat1(isdat) - isdat2(isdat-numdrop) = isdat2(isdat) - isdat3(isdat-numdrop) = isdat3(isdat) - isdat1(isdat) = 0 - isdat2(isdat) = 0 - isdat3(isdat) = 0 - end if -2 continue - nsdat = nsdat-numdrop -c call report(nsdat,isdat1,isdat2) - return - end - subroutine dotmov(updot,rtdot,soutq,lsout,iddot) -c -c iddot = 0 for single dot, 1 for double -c - character*80 soutq,notexq - character*1 sq,chax - sq = chax(92) - lfmtup = lfmt1(updot) - lfmtrt = lfmt1(rtdot) - write(notexq,'(a37,f'//chax(48+lfmtup)//'.1,a2,f'//chax(48+lfmtrt) - * //'.1,a15)') - * sq//'makeatletter'//sq//'def'//sq//'C@Point#1#2{'//sq// - * 'PMXpt{',updot,'}{',rtdot,'}'//chax(48+iddot)//'}'//sq - * //'makeatother' -c -c Example of string just created: -c \makeatletter\def\C@Point#1#2{\PMXpt{.5}{.5}}\makeatother\ -c - lnote = 54+lfmtup+lfmtrt - call addstr(notexq(1:lnote),lnote,soutq,lsout) - return - end - subroutine dotrill(iv,ip,iornq,noteq,lnoten,notexq,lnote) - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - character*1 chax - character*8 noteq - character*79 notexq - logical tronly,btest - do 1 itr = 1 , ntrill - if (iv.eq.ivtrill(itr) .and. ip.eq.iptrill(itr)) go to 2 -1 continue - print*,'Problem in dotrill. Call Dr. Don' - stop -2 continue - tronly = xnsktr(itr) .lt. 0.01 - if (tronly) then - notexq = chax(92)//'zcharnote' - lnote = 10 - else if (btest(iornq,7)) then - notexq = chax(92)//'Trille' - lnote = 7 - else - notexq = chax(92)//'trille' - lnote = 7 - end if - notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' - lnote = lnote+lnoten+1 -c -c Write trill duration to nearest tenth of a noteskip -c - if (tronly) then - notexq = notexq(1:lnote)//chax(92)//'it tr}' - lnote = lnote+7 - return - end if - if (xnsktr(itr) .lt. .95) then - nfmt = 2 - else if (xnsktr(itr) .lt. 9.95) then - nfmt = 3 - else - nfmt = 4 - end if - write(notexq(lnote+1:lnote+nfmt),'(f'//chax(48+nfmt)//'.1)') - * xnsktr(itr) - lnote = lnote+nfmt - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - return - end - subroutine endslur(stemup,upslur,nolev,iupdn,ndxslur,ivoff,ncm, - * soutq,lsout,fontslur) -c -c Only called to end slur started in dograce. -c - logical shift,stemup,upslur,fontslur - character*80 soutq - character*79 notexq - character*8 noteq - character*1 chax - shift = .not.stemup .and. .not.upslur - if (.not.shift) then -c -c No shift needed -c - notexq = chax(92)//'tslur' - lnote = 6 - else -c -c Shift needed -c - notexq = chax(92)//'ts' - lnote = 3 - end if -c if (ndxslur .lt. 10) then -c notexq = notexq(1:lnote)//chax(48+ndxslur) -c lnote = lnote+1 -c else -c notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}' -c lnote = lnote+4 -c end if -c -cc Print 11-ndxslur -c Print 23-ndxslur -c -c if (11-ndxslur .lt. 10) then - if (23-ndxslur .lt. 10) then -c notexq = notexq(1:lnote)//chax(59-ndxslur) - notexq = notexq(1:lnote)//chax(71-ndxslur) - lnote = lnote+1 - else if (23-ndxslur .lt. 20) then -c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' - notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' - lnote = lnote+4 - else - notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' - lnote = lnote+4 - end if - call notefq(noteq,lnoten,nolev+iupdn+ivoff,ncm) - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+lnoten - if (shift) then - if (fontslur) then - notexq = notexq(1:lnote)//'{-.6}' - else - notexq = notexq(1:lnote)//'{-.8}' - end if - lnote = lnote+5 - end if - call addstr(notexq,lnote,soutq,lsout) - return - end - subroutine errmsg(lineq,iccount,ibarno,msgq) - parameter(nm=24) - common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, - * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 - logical lastchar,fbon,issegno,isheadr,isvolt - character*128 lineq - character*78 outq - character*(*) msgq - character*1 chax - common /truelinecount/ linewcom(20000) - if (iccount .le. 78) then - outq = lineq(1:78) - iposn = iccount - else - outq = '... '//lineq(55:128) - iposn = iccount-50 - end if - print* - ibarnop = ibarno - if (linesinpmxmod.eq.0 .or. - * nline .gt. line1pmxmod+linesinpmxmod) then -c -c Error is in main .pmx file -c -c nlinep = nline-linesinpmxmod -c Correct for comments not copied into buffer - nlinep = linewcom(nline)-linesinpmxmod - else -c -c Error is in include file -c - ibarnop = 0 - nlinep = nline-line1pmxmod+1 - call printl( - * 'ERROR in include file named above, description given below') - end if - open(19,file='pmxaerr.dat') - write(19,'(i6)') nlinep - close(19) - ndigbn = max(1,int(log10(ibarnop+.1)+1)) - ndignl = int(log10(nlinep+.1)+1) - lenmsg = index(msgq,'!')-1 -c -c Split off msgq(..) since UNIX compilers don't allow concat substring!!! -c - write(*,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)// - *',$)')' ERROR in line ',nlinep,', bar ',ibarnop - write(*,'(1x,a)')msgq(1:lenmsg) - write(15,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)// - *',$)')' ERROR in line ',nlinep,', bar ',ibarnop - write(15,'(a)')msgq(1:lenmsg) - i10 = iposn/10 - i1 = iposn-10*i10 - write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v' - write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v' - print*,outq(1:78) - write(15,'(a)')' '//outq(1:78) - write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^' - write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^' - return - end - subroutine eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk) -c -c Get elemskips to previous note. Called only for graces, no xtups involved. -c - parameter (nm=24) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - character*1 ulq,sepsymq,sq - logical beamon,firstgulp,figbass,figchk,isfig - real*4 tstart(80),space(80) - common /comtol/ tol - itnd = nint(to(in)) - if (ip.eq.1 .or. itnd.eq.itrpt) then -c -c Start of bar or after rpt. -c - esk = fbar - return - else - esk = 0. - itprev = itnd-nodur(ivx,ip-1) - do 1 iib = ib , 1 , -1 - if (tstart(iib) .lt. itprev+tol) then -c -c This is the block -c - nnsk = nint(float((itnd-itprev))/space(iib)) - esk = esk+nnsk*feon(space(iib)) - return - else - nnsk = nint((itnd-tstart(iib))/space(iib)) - esk = esk+nnsk*feon(space(iib)) - itnd = nint(tstart(iib)) - end if -1 continue - end if - print*,'Problem in eskb4. Send files to Dr. Don' - stop - end - function f1eon(time) - f1eon = sqrt(time/2) - return - end - function feon(time) - common /comeon/ eonk,ewmxk - feon = sqrt(time/2)**(1.-eonk)*ewmxk - return - end - subroutine findbeam(ibmrep,numbms,mapfb) -c -c Called once per voice per bar, after setting forced beams. -c - parameter (nm=24) - dimension mask(49,3),nummask(3),eqonly(49,3) -c integer numbms(nm),ipr(48),nip1(0:47),nip2(0:47),mapfb(16), -c * itr(48),nodue(48) -c logical short(48),eqonly - integer numbms(nm),ipr(248),nip1(0:247),nip2(0:247),mapfb(16), - * itr(248),nodue(248) - logical short(248),eqonly - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - common /comipl2/ ipl2(nm,200) - common /combeam/ ibmtyp - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /comtol/ tol - character*1 ulq,sepsymq,sq - logical beamon,firstgulp,figbass,figchk, - * isfig,btest - data nip1,nip2 /496*0/ - data nummask / 29 , 49 , 12 / - data mask - * / 65535, 4095, 65520, 255, 65280, 63, - * 252, 16128, 64512, 15, 240, 3840, - * 61440, 7, 14, 112, 224, 1792, - * 3584, 28672, 57344, 3, 12, 48, - * 192, 768, 3072, 12288, 49152, 20*0 , - * 16777215, 65535, 16776960, 4095, 65520, 1048320, - * 16773120, 255, 65280, 16711680, 63, 252, - * 16128, 64512, 4128768, 16515072, 15, 60, - * 240, 3840, 15360, 61440, 983040, 3932160, - * 15728640, 7, 14, 112, 224, 1792, - * 3584, 28672, 57344, 458752, 917504, 7340032, - * 14680064, 3, 12, 48, 192, 768, - * 3072, 12288, 49152, 196608, 786432, 3145728, - * 12582912, - * 4095, 255, 4080, 15, 240, 3840, - * 3, 12, 48, 192, 768, 3072, - * 37*0 / - data eqonly /3*.true.,46*.false.,7*.true.,91*.false./ - ip = 0 - nreal = 0 - itnow = 0 -1 continue - ip = ip+1 - if (ip .gt. nn(ivx)) go to 9 -11 if (nodur(ivx,ip).eq.0) then -c -c Ignore all xtup notes except the last, the one with nodur > 0 . -c Xtups are irrelevant here since they are already all in forced beams. -c Will update itnow by nodur at the END of this loop -c - ip = ip+1 - go to 11 - end if - nreal = nreal+1 - nodue(nreal) = nodur(ivx,ip) - short(nreal) = nodue(nreal).lt.16 .and. - * .not.btest(irest(ivx,ip),0) -c -c Rule out notes that have 'alone'-flag set -c - * .and..not.btest(islur(ivx,ip),18) - ipr(nreal) = ip - itr(nreal) = itnow - if (nodue(nreal) .eq. 1) then -c -c 64th gap -c - if (mod(itnow,2) .eq. 0) then -c -c Start of 32nd gap, lump with following note -c - ip = ip+1 - nodue(nreal) = 1+nodur(ivx,ip) - itnow = itnow+nodue(nreal) - else -c -c End of 32nd gap, lump with preceeding note -c - nreal = nreal-1 - nodue(nreal) = 1+nodue(nreal) - itnow = itnow+1 - end if - else - itnow = itnow+nodur(ivx,ip) - end if - go to 1 -9 continue - ir1 = 1 - itseg = lenbar/ibmrep - do 13 irep = 1 , ibmrep -c -c Set bitmaps for all shorts neighbored by a short. Each bit represents a -c span of 32nd note. maps, mapm, mape record start, full duration, and end -c of consecutive span of beamable (<1/4) notes. -c - maps = 0 - mapm = 0 - mape = 0 - itend = itseg*irep - itoff = itend-itseg - do 2 ir = ir1 , nreal - it2 = itr(ir)+nodue(ir)-2 - if (it2 .ge. itend) then - ir1 = ir - go to 14 - end if -c if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal - if (short(ir).and.((ir.gt.1.and.short(max(ir-1,1))).or. - * (ir.lt.nreal.and.short(ir+1)))) then - ib1 = (itr(ir)-itoff)/2 - ib2 = (it2-itoff)/2 - if (max(ib1,ib2).gt.47 .or. ir.gt.48 .or. - * min(ib1,ib2).lt.0) return -c -c Must have an odd number obe beats in a long bar. Auto-beam won't work -c - nip1(ib1) = ipr(ir) - nip2(ib2) = ipr(ir) -c -c nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip -c - maps = ibset(maps,ib1) - mape = ibset(mape,ib2) - do 3 ib = ib1 , ib2 - mapm = ibset(mapm,ib) -3 continue - end if -2 continue -14 continue - if (mapm .eq. 0) go to 13 -c -c Zero out bits from forced beams -c - maps = iand(maps,not(mapfb(irep))) - mapm = iand(mapm,not(mapfb(irep))) - mape = iand(mape,not(mapfb(irep))) -c -c Compare map with template. -c - do 4 it = 1 , nummask(ibmtyp) - masknow = mask(it,ibmtyp) - if (iand(masknow,mapm) .eq. masknow) then -c -c Find least significant bit in the mask to check start time -c - mtemp = masknow - maskm = masknow - do 5 is1 = 0 , 47 - if (iand(1,mtemp) .eq. 1) go to 6 - mtemp = ishft(mtemp,-1) -5 continue -6 continue - if (iand(ishft(1,is1),maps) .eq. 0) go to 4 -c -c is1 is the bit where the beam starts. Continue shifting to -c find most significant bit in the mask to check ending time -c - do 7 is2 = is1 , 47 - mtemp = ishft(mtemp,-1) - if (iand(1,not(mtemp)) .eq. 1) go to 8 -7 continue -8 continue -c -c is2 is now the bit on which the beam ends. -c - if (iand(ishft(1,is2),mape) .eq. 0) go to 4 -c -c Did we pick out a single note from the middle of a longer sequence? -c - if (nip1(is1) .eq. nip2(is2)) go to 4 -c -c We almost have a beam. Check equality of notes if needed. -c - if (eqonly(it,ibmtyp)) then - do 10 ip = nip1(is1) , nip2(is2) - if (nodur(ivx,ip) .ne. 8) then -c -c There is a non-1/8th note in this beam. Exit if not 2 quarters -c - if (is2-is1 .ne. 15) go to 4 -c -c Beam is 2 quarters long. Check if can split in half. -c - ithalf = 0 - do 20 iip = nip1(is1) , nip2(is2) - ithalf = ithalf+nodur(ivx,iip) - if (ithalf .gt. 16) go to 4 - if (ithalf .eq. 16) go to 21 -20 continue - print*,'Problem in findbeam, please call Dr. Don' - go to 4 -21 continue -c -c Otherwise, split in half by keeping only the first half. Other half will -c be picked up later, assuming masks are listed longest first. -c - is2 = is1+7 -c -c Reset maskm (since only used part of mask), used later to zero out -c bits that contain beams -c - maskm = 0 - do 15 is = is1 , is2 - maskm = ibset(maskm,is) -15 continue - go to 16 - end if -10 continue - end if -16 continue -c -c This is a beam. If last "effective" ends on odd 64th, add 1 more -c -c if (abs(mod(to(iand(255,ipl(ivx,nip2(is2)))) -c * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then - if (abs(amod(to(ipl2(ivx,nip2(is2))) - * +nodur(ivx,nip2(is2))+.5*tol,2.)) .gt. tol) then - nip2(is2) = nip2(is2)+1 - end if - numbms(ivx) = numbms(ivx)+1 - numnew = numbms(ivx) - call logbeam(numnew,nip1(is1),nip2(is2)) -c -c Zero out the appropriate bits so these notes don't get used again -c - mapm = iand(mapm,not(maskm)) - if (mapm.eq.0) go to 13 - maps = iand(maps,not(maskm)) - mape = iand(mape,not(maskm)) - end if -4 continue -13 continue - return - end - subroutine findeonk(nptr1,nptr2,wovera,xelsk,dtmin,dtmax,eonk0) - parameter (nkb=3999,maxblks=4000) -c -c Compute an exponent eonk for use in the "flattened" formula for elemskips -c vs time. We must solve the eqution f = 0. Initial quess is eonk0. -c - logical gotclef - common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), - * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, - * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) - common /comtol/ tol - common /comeon/ eonk,ewmxk - eonk = eonk0 - niter = 0 -1 continue - ewmxk = f1eon(dtmax)**eonk - niter = niter+1 - esum = 0. - desum = 0. - do 2 iptr = nptr1 , nptr2 - targ = durb(iptr)/sqzb(iptr) - esum = esum+nnpd(iptr)*sqzb(iptr)*feon(targ) - detarg = sqrt(targ/2*(dtmax/targ)**eonk)*alog(dtmax/targ) - desum = desum+nnpd(iptr)*sqzb(iptr)*detarg -2 continue - f = wovera*feon(dtmin)-xelsk-esum - fp = wovera*sqrt(dtmin/2*(dtmax/dtmin)**eonk)*alog(dtmax/dtmin) - * -desum - if (abs(fp).lt.tol .or. abs(eonk-.5).gt..5 .or. niter.gt.100) then - call printl( - * 'Error in findeonk. Please send source to Dr. Don') - eonk = 0. - ewmxk = 1. - return - end if - dsoln = -f/fp - if (abs(dsoln) .lt. .1*tol) return -c -c Not converged yet, try again -c - eonk = eonk+dsoln - go to 1 - end - function fnote(nodur,ivx,ip,nacc) -c -c This return the real duration of a note -c - parameter (nm=24) - integer*4 nodur(nm,200),nacc(nm,200) - logical btest - ipback = ip - if (nodur(ivx,ip) .gt. 0) then - if (ip .gt. 1) then -c -c Check if this is last note of xtup -c - if (nodur(ivx,ip-1).eq.0) then - ipback = ip-1 - go to 2 - end if - end if - fnote = nodur(ivx,ip) - return - end if -2 continue -c -c Count back to prior non zero note. Start at ip to avoid neg index if ip=1. -c Count how many doubled xtups notes there are from ip-1 to first note. -c - ndoub = 0 - do 1 ip1m1 = ipback , 1 , -1 - if (nodur(ivx,ip1m1) .gt. 0) go to 4 - if (ip1m1.lt.ip .and. btest(nacc(ivx,ip1m1),18)) ndoub=ndoub+1 -1 continue -4 continue -c -c count forward to next non-0 nodur. Start at ip in case last note of xtup. -c - do 3 iip = ip , 200 -c -c Count doubled xtup notes from ip to end. -c - if (btest(nacc(ivx,iip),18)) ndoub = ndoub+1 - if (nodur(ivx,iip) .gt. 0) then -c fnote = nodur(ivx,iip)/float(iip-ip1m1) - fnote = nodur(ivx,iip)/float(iip-ip1m1+ndoub) - if (btest(nacc(ivx,ip),18)) then - fnote = 2*fnote - else if (btest(nacc(ivx,ip),27)) then - fnote = 1.5*fnote - else if (ip .gt. 1) then - if (btest(nacc(ivx,ip-1),27)) fnote = .5*fnote - end if - return - end if -3 continue - print*,' ' - call printl - * ('Probable misplaced barline or incorrect meter, stopping') -c call printl('Program error in fnote, send source to Dr. Don') - call stop1() - end - subroutine g1etchar(lineq,iccount,charq) - parameter(nm=24) - common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, - * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 - logical lastchar,issegno,isheadr,isvolt,fbon - common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac - logical mrecord,mplay,endmac - character*1 charq - character*128 lineq,lnholdq -c -c Gets the next character out of lineq*128. If pointer iccount=128 on entry, -c then reads in a new line. Resets iccount. Ends program if no more input. -c - if (iccount .eq. 128) then - call read10(lineq,lastchar) - if (lastchar) return - if (.not.endmac) then - iccount = 0 - if (.not.mplay) nline = nline+1 - else - endmac = .false. - iccount = icchold - lineq = lnholdq - end if - if (mrecord) then - call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) - end if - end if - iccount = iccount+1 - charq = lineq(iccount:iccount) - return - end - subroutine g1etnote(loop,ifig,optimize,fulltrans) - parameter (nm=24,nkb=3999,mv=24576,maxblks=4000) - character*1 chax - common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), - * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, - * nbars,itsofar(nm),nib(nm,15),nn(nm), - * rest(nm,200),lenbr0,lenbr1,firstline,newmeter - common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), - * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, - * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) - common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, - * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 - common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40), - * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), - * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), - * nistaff(0:40) - common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) - common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1, - * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS - logical lastchar,firstline,rest,loop,newmeter,fbon,issegno,barend, - * isheadr,fulbrp,usefig,isvolt,iskchb,kchmid,plusmin,ornrpt, - * stickyS - common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac - common /commus/ musize,whead20 - logical mrecord,mplay,endmac,shifton,gotclef,optimize - character*128 lineq,lnholdq - character*1 charq,dotq,dumq,durq,charlq - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc,cdot - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - character*65536 bufq - integer*2 lbuf(maxblks) - common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq - logical novshrinktop,upslur,fontslur,ztrans, - * WrotePsslurDefaults,cstuplet - common /comnvst/ novshrinktop,cstuplet - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - character*51 literq(3) - common /comligfont/ isligfont - logical isligfont - common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), - * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans - logical EarlyTransOn,LaterInstTrans - logical fulltrans - common /comsize/ isize(nm) - data literq - * /'Literal TeX string cannot start with 4 backslashes!', - * 'TeX string must have <129 char, end with backslash!', - * 'Type 2 or 3 TeX string can only start in column 1!'/ - cdot = .false. -1 call g1etchar(lineq,iccount,charq) - if (charq .ne. ' ') charlq = charq - if (lastchar) then - if (index('/%',charlq) .eq. 0) then - print* - print*,'WARNING:' - print*,'Last non-blank character is "',charlq,'", not "/,%"' - print*,'ASCII code:',ichar(charlq) - write(15,'(/a)')'Last non-blank character is "'//charlq// - * '", not "/,%"' - write(15,'(a11,2x,i3)')'ASCII code:',ichar(charlq) -c -c Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1. -c - ilbuf = ilbuf-1 - lbuf(ilbuf) = lbuf(ilbuf)+2 - bufq = bufq(1:ipbuf)//' /' - write(15,*)'appending <blank>/' - print*,'appending <blank>/' - lineq = lineq(1:iccount)//' /' - lastchar = .false. - go to 1 - end if - return - end if - if (charq .eq. ' ') then - go to 1 - else if (charq.eq.'%' .and. iccount.eq.1) then - iccount = 128 - go to 1 -c -c Replacement 1/22/12 since gfortran 4.7 with -O was choking here! -c -c else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. - else if (index('abcdefg',charq).gt.0 .or. - * charq.eq.'r') then -c -c This is a note/rest. gotclef is only used for checking for clef before "/" -c - if (cdot) go to 28 - if (gotclef) gotclef=.false. - idotform = 0 - numnum = 0 - plusmin = .false. -28 nnl(ivx) = nnl(ivx)+1 - if (nnl(ivx) .gt. 200) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '>200 notes in line of music. Use smaller blocks!') - call stop1() - end if - dotq = 'x' -c -c Check if this is 'r ' and previous note was full-bar-pause -c - fulbrp = charq.eq.'r' .and. lineq(iccount+1:iccount+1) .eq.' ' - * .and. nnl(ivx).gt.1 .and. rest(ivx,max(1,nnl(ivx)-1)) .and. - * nodur(ivx,max(1,nnl(ivx)-1)) .eq. lenbar -2 call g1etchar(lineq,iccount,durq) - ic = ichar(durq) - if (ic.le.57 .and. ic.ge.48) then -c -c Digit -c - if (numnum .eq. 0) then - nnodur = ic-48 - numnum = 1 - go to 2 - else if (numnum .eq. 1) then - if (charq .eq. 'r') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Only one digit allowed after rest symbol "r"!') - call stop1() - end if - numnum = 2 - if (plusmin) then - print* - print*,'*********WARNING*********' - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Before version 1.2, +/- was ignored if octave was!') - print*, - * 'explicitly specified. May need to edit old editions' - end if - go to 2 - else - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '>2 digits in note symbol!') - call stop1() - end if - else if (durq.eq.'d') then - dotq = durq - if (lineq(iccount+1:iccount+1) .eq. 'd') then - iddot = 1 - iccount = iccount+1 -c -c Since we flow out, double dots won't work with other dot options -c - end if - if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then -c -c move a dot, provided a number follows. -c - call g1etchar(lineq,iccount,durq) - call g1etchar(lineq,iccount,durq) - if (index('0123456789-.',durq) .eq. 0) then -c -c Backup, exit the loop normally -c - iccount = iccount-2 - go to 2 - end if - call readnum(lineq,iccount,dumq,fnum) - if (index('+-',dumq) .gt. 0) then -c -c Vertical shift also -c - call g1etchar(lineq,iccount,durq) - if (index('0123456789-.',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected number after 2nd +/- (shift dot)!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - end if - iccount = iccount-1 - end if - go to 2 - else if (index('<>',durq) .gt. 0) then -c -c Accidental shift -c -c if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then - if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, -c * 'Expected "f", "s", or "n" before "<" or ">"!') - * 'Expected "f", "s", "n" or "A" before "<" or ">"!') - call stop1() - end if - ipm = 1 - if (durq .eq. '<') ipm=-1 - call g1etchar(lineq,iccount,durq) - if (index('123456789.0',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected number after </> (accidental shift)!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - fnum = ipm*fnum - if (fnum.lt.-5.35 .or. fnum.gt.1.0) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Horizontal accidental shift must be >-5.35 and <1.0!') - call stop1() - end if - iccount = iccount-1 - go to 2 - else if (index('+-',durq) .gt. 0) then - if (charq .ne. 'r') then - if (index('fsnA',lineq(iccount-1:iccount-1)) .gt. 0) then - ipm = 1 - if (durq .eq. '-') ipm=-1 - if (index('0123456789',lineq(iccount+1:iccount+1)) - * .gt.0) then -c -c This may be start of accidental shift, but may be octave jump; then duration -c - icsav = iccount - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - if (index('+-',durq) .gt. 0) then -c -c This is an accid shift since there's a 2nd consecutive signed number. -c Check size of 1st number. -c - if (fnum .gt. 30.5) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Vertical accidental shift must be less than 31!') - call stop1() - end if - ipm = 1 - if (durq .eq. '-') ipm = -1 - call g1etchar(lineq,iccount,durq) - if (index('1234567890.',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected 2nd number of accidental shift)!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - fnum = ipm*fnum - if (fnum.lt.-5.35 .or. fnum.gt.1.0) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Horiz. accidental shift must be >-5.35 and <1.0!') - call stop1() - end if - iccount = iccount-1 - go to 2 - else -c -c Not accid shift, reset, then flow out -c - iccount = icsav - end if - end if - end if - plusmin = .true. - if (numnum .eq. 2) then - print* - print*,'*********WARNING*********' - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Before version 1.2, +/- was ignored if octave was!') - print*, - * 'explicitly specified. May need to edit old editions' - end if - go to 2 -c -c It's a rest containing +|- . Must refer to a vertical shift. Read past. -c - else - call g1etchar(lineq,iccount,durq) - call readnum(lineq,iccount,durq,dum) - iccount = iccount-1 - go to 2 - end if -c else if (index('ulare',durq) .gt. 0) then - else if (index('ularec',durq) .gt. 0) then - go to 2 - else if (durq .eq. 'S') then -c -c Stemlength change -c - call g1etchar(lineq,iccount,durq) - if (index('.0123456789:',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'There must be a number or colon here!') - call stop1() - end if - if (durq .eq. ':') then - if (.not.stickyS) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Turned off sticky stemshrinks without turning on!') - call stop1() - end if - stickyS = .false. - go to 2 - end if - call readnum(lineq,iccount,durq,dum) - if (dum.lt..5 .or. dum.gt.4.) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Stemlength shortening must be from .5 to 4!') - call stop1() - end if - if (durq .ne. ':') then - iccount = iccount-1 - else - if (stickyS) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Turned on sticky stemshrinks when already on!') - call stop1() - end if - stickyS = .true. - end if - go to 2 - else if (index('fsn',durq) .gt. 0) then -c -c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so -c MUST come right after "f,s,n" -c - if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 - go to 2 - else if (durq .eq. 'p') then - fulbrp = charq.eq.'r' - if (.not. fulbrp) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'The option "p" only works with "r" (rest)!') - call stop1() - end if - go to 2 - else if (durq .eq. 'b') then - if (charq .ne. 'r') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'You entered "b"; I expected "rb"!') - call stop1() - else if (numnum .eq. 2) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'You entered "r" & "b" with two numbers!') - end if - go to 2 - else if (durq .eq. 'x') then -c -c Xtuplet. Count number of doubled notes (for unequal xtups) -c - if (btest(nacc(ivx,nnl(ivx)),18)) then - ndoub = 1 - else - ndoub = 0 - end if -c -c Will set all durations to 0 except last one. -c - call g1etchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'First char after "x" in xtuplet must be "1"-"9"!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - if (fnum .gt. 99) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Xtuplet cannot have more than 99 notes!') - call stop1() - else if (index(' DFnd',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Only legal characters here are " ","D","F","n"!') - call stop1() - end if -c -c End of mandatory xtup inputs. Check for options. Note D,F,d must precede n. -c - if (index('DF',durq) .gt. 0) then -c -c Double xtup note to make an un= xtup. Here, number already set, but may also -c have used this before number was set. -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) - ndoub = 1 - call g1etchar(lineq,iccount,durq) - else if (durq .eq. 'd') then - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) - call g1etchar(lineq,iccount,durq) - end if - if (durq .eq. 'n') then -c -c Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'. -c - numshft = 0 -30 call g1etchar(lineq,iccount,durq) - if (durq .eq. 'f') then - go to 30 - else if (index('+-',durq) .gt. 0) then - numshft = numshft+1 - if (numshft .eq. 3) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Only 2 shifts are allowed after "n" in xtup!') - call stop1() - end if - call g1etchar(lineq,iccount,durq) - if (index('0123456789.',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'This character should be a digit or "."!') - call stop1() - end if - call readnum(lineq,iccount,durq,snum) - iccount = iccount-1 - if ((numshft.eq.1 .and. snum.gt.15.1) .or. - * (numshft.eq.2 .and. snum.gt.1.51)) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Shift number after "n" in xtup is out of range!') - call stop1() - end if - go to 30 - else if (durq .eq. 's') then -c -c Slope alteration for bracket -c - call getchar(lineq,iccount,durq) - if (index('+-',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'For slope adjustment, this character must be "+" or "-"!') - call stop1() - end if - call g1etchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'This character should be a digit!') - call stop1() - end if - call readnum(lineq,iccount,durq,snum) - iccount = iccount-1 - if (nint(snum) .gt. 15) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Slope adjustment cannot exceed 15!') - call stop1() - end if - go to 30 - else if (index('123456789',durq) .gt. 0) then -c -c Unsigned integer => alternate printed number -c - call readnum(lineq,iccount,durq,snum) - if (snum .gt. 15.1) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Alternate xtup number after "n" must be <16!') - call stop1() - end if - iccount = iccount-1 - go to 30 - else if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after "n" in xtup!') - call stop1() - end if - end if - ntup = nint(fnum) - do 6 itup = 2 , ntup - nodur(ivx,nnl(ivx)) = 0 - nnl(ivx) = nnl(ivx)+1 -110 call g1etchar(lineq,iccount,durq) - if (durq.eq.' ') then - go to 110 - else if (durq .eq. 'o') then -c -c Ornament in xtup. "o" symbol must come AFTER the affected note -c - call g1etchar(lineq,iccount,dumq) - if (index('(stmx+Tup._)e:>^bc',dumq) .eq. 0 ) then - if (index('fg',dumq) .gt. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Fermata or segno not allowed in xtuplet!') - else - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal ornament!') - end if - call stop1() - end if - if (dumq .eq. 'T') then -c -c Trill. may be followed by 't' and/or number. read 'til blank -c -29 call g1etchar(lineq,iccount,dumq) - if (dumq .ne. ' ') go to 29 - else if (dumq .eq. 'e') then - call g1etchar(lineq,iccount,dumq) - if (index('sfn?',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after "e" in edit. accid. symbol!') - call stop1() - end if - call g1etchar(lineq,iccount,dumq) - if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq) - else if (dumq .eq. ':') then - if (lineq(iccount+1:iccount+1) .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '":" must be followed by blank in "o: "!') - call stop1() - else if (.not.ornrpt) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Turned off repeated ornaments before they were on!') - call stop1() - end if - ornrpt = .false. - else - call g1etchar(lineq,iccount,dumq) - end if - if (index('+- :',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in ornament symbol!') - call stop1() - end if - if (dumq .eq. ':') then - if (lineq(iccount+1:iccount+1) .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '":" must be followed by blank in "o: "!') - call stop1() - else if (ornrpt) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Turned on repeated ornaments but already on!') - call stop1() - end if - ornrpt = .true. - end if - if (index('+-',dumq) .gt. 0) then - if (index('0123456789',lineq(iccount+1:iccount+1)) - * .eq. 0) then - call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, - * 'There should be an integer here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - if (durq .eq. ':') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Cannot shift AND repeat an ornament!') - call stop1() - end if -c -c 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas. -c - if (index('+-',durq) .gt. 0) then - if (index('.0123456789',lineq(iccount+1:iccount+1)) - * .eq. 0) then - call errmsg(lineq,iccount+1, - * ibarcnt-ibaroff+nbars+1, - * 'There should be a number here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - end if - end if - go to 110 - else if (index('st(){}',durq) .gt. 0) then -c -c Slur in xtup -c - iposn = 0 - numint = 0 -15 call g1etchar(lineq,iccount,dumq) - iposn = iposn+1 - if (index('udlbfnht',dumq) .gt. 0) then - if (dumq.eq.'t' .and. durq.eq.'t') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Cannot use "t" as an option on a tie!') - call stop1() - end if - go to 15 - else if (index('+-',dumq) .gt. 0) then - numint = numint+1 - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - if (numint .eq. 1) then - if (nint(fnum) .gt. 30) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Magnitude of slur height adjustment cannot exceed 30!') - call stop1() - end if - else if (numint .eq. 2) then - if (abs(fnum).gt.6.3) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Slur horiz shift must be in the range (-6.3,6.3)!') - call stop1() - end if - else -c -c Third signed integer, must be a midslur or curve spec. -c - if (abs(fnum).gt.31) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Slur midheight must be in the range (-31,31)!') - call stop1() - end if - if (durq .eq. ':') then -c -c Expecting curve parameters. Get two numbers -c - do 40 i = 1 , 2 - iccount = iccount+1 - fnum = ichar(lineq(iccount:iccount))-48 - if (abs(fnum-3.5) .gt. 3.6) then - call errmsg(lineq,iccount, - * ibarcnt-ibaroff+nbars+1, - * 'Slur curve parameter must be in range (0,7)!') - call stop1() - end if -40 continue - iccount = iccount+1 - end if - end if - iccount = iccount-1 - go to 15 - - else if (dumq .eq. 's') then -c -c What follows should be one or two signed numbers for adjustment of line break -c slur, end of 1st segment or start of second. -c - if (fontslur) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'May not use linebreak slur options with font-based slurs!') - call stop1() - end if - call g1etchar(lineq,iccount,dumq) - if (index('+-',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'This character must be "+" or "-"!') - call stop1() - end if - iccount = iccount+1 - call readnum(lineq,iccount,dumq,fnum) - if (nint(fnum) .gt. 30) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Magnitude of slur height adjustment cannot exceed 30!') - call stop1() - end if - if (index('+-',dumq) .gt. 0) then - iccount = iccount+1 - call readnum(lineq,iccount,dumq,fnum) - if (abs(fnum) .gt. 6.3) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Slur horiz shift must be in range (-6.3,6.3)!') - call stop1() - end if - end if - iccount = iccount-1 - go to 15 - else if (dumq .eq. 'H' .and. iposn.gt.1) then - if (lineq(iccount+1:iccount+1) .eq. 'H') - * iccount=iccount+1 - go to 15 - else if (dumq .eq. 'p') then -c -c local change in postscript slur/tie adjustment default -c - if (fontslur) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Must use postscript slurs ("Ap") to use this option!') - call stop1() - end if - call g1etchar(lineq,iccount,dumq) - if (index('+-',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected "+" or "-" here!') - call stop1() - end if - call g1etchar(lineq,iccount,dumq) - if (index('st',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected "s" or "t" here!') - call stop1() - end if - go to 15 - else if (dumq .ne. ' ') then - ic = ichar(dumq) - if ((ic.ge.48.and.ic.le.57) .or. - * (ic.ge.65.and.ic.le.90)) then - if (iposn .eq. 1) then - if (durq.eq.'t' .and. fontslur) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Slur ID not allowed on non-postscript tie!') - call stop1() - end if - go to 15 - end if - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Slur ID must be 2nd character in slur symbol!') - call stop1() - end if - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in slur symbol!') - call stop1() - end if - go to 110 - else if (index('0123456789#-nx_',durq) .gt. 0) then -c -c We have a figure. Only allow on 1st note of xtup -c - if (itup .ne. 2) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Figure in xtup only allowed on 1st note!') - call stop1() - else if (durq.eq.'x') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'No floating figures in xtuplets!') - call stop1() - end if - if (usefig .and. ivx.eq.1) ifig = 1 -26 call g1etchar(lineq,iccount,durq) - if (index('0123456789#-n_.:',durq) .gt. 0) then - go to 26 - else if (durq .eq. 's') then - isligfont = .true. - go to 26 - else if (durq .eq. '+') then -c -c vertical offset, must be integer then blank -c - call g1etchar(lineq,iccount,durq) - if (index('123456789',durq) .ne. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Integer for vertical offset expected here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Vertical offset must terminate figure!') - call stop1() - end if - iccount = iccount-1 - go to 26 - else if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in figure in xtuplet!') - call stop1() - end if - go to 110 - else if (durq .eq. 'G') then - ngr = 1 -79 call g1etchar(lineq,iccount,charq) - if (index('123456789',charq) .gt. 0) then - call readnum(lineq,iccount,durq,fnum) - ngr = nint(fnum) - iccount = iccount-1 - go to 79 - else if (index('AWulxs',charq) .gt. 0) then - go to 79 - else if (charq .eq. 'm') then - call g1etchar(lineq,iccount,charq) - if (index('01234',charq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'A digit less than 5 must follow "m" in a grace note!') - call stop1() - end if - go to 79 - else if (charq .eq. 'X') then -c -c Space before main note -c - call g1etchar(lineq,iccount,charq) - if (index('0123456789.',charq) .gt. 0) then - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - go to 79 - else - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'A number must follow "X" in a grace note!') - call stop1() - end if - end if -c -c At this point, charq is first note name in rest (grace?) -c - do 71 igr = 1 , ngr - numnum = 0 - if (igr .gt. 1) then -75 call g1etchar(lineq,iccount,charq) - if (charq .eq. ' ') go to 75 - end if - if (index('abcdefg',charq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'In grace, expected "a"-"g"!') - call stop1() - end if -78 call g1etchar(lineq,iccount,charq) - if (charq .ne. ' ') then - if (index('1234567',charq) .gt. 0) then - if (numnum .eq. 1) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Only one of "+-1234567" allowed here in grace!') - call stop1() - end if - numnum = 1 - go to 78 - else if (index('+-nfs',charq) .gt. 0) then - go to 78 - end if -c -c Digits are possible octave numbers -c - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after note name in grace!') - call stop1() - end if -71 continue - go to 110 - else if (durq .eq. chax(92)) then - call chklit(lineq,iccount,literr) - if (literr .gt. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * literq(literr)) - call stop1() - end if - go to 110 - else if (durq .eq. 'M') then -c -c Temporary trap until I get around putting this in pmxb -c - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Macros not yet allowed in xtuplets!') - call stop1() - else if (durq .eq. 'X') then - call g1etx(lineq,iccount,.false.,shifton, - * ibarcnt-ibaroff+nbars+1,udsp(ibarcnt+nbars+1),wheadpt) - go to 110 - else if (durq .eq. 'z') then -c -c Chord note in xtup. Read past for now. -c -33 call g1etchar(lineq,iccount,durq) - if (durq .ne. ' ') go to 33 - go to 110 - else if (durq .eq. 'D') then -c -c Dynamic mark -c - call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1) - go to 110 - else if (durq .eq. '%') then - if (iccount .ne. 1) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Comment must have "%" in column 1!') - call stop1() - end if - iccount = 128 - go to 110 - else if (durq .eq. '?') then - call getchar(lineq,iccount,durq) - if (durq .eq. ' ') then - iccount = iccount-1 - go to 110 - end if - if (durq .ne. '-') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expecting "-"') - call stop1() - end if - call getchar(lineq,iccount,durq) - if (index('0123456789.',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expecting number') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - go to 110 -c+++ - else if (durq.eq.']' .and. lineq(iccount+1:iccount+1).eq.'[' - * .and. lineq(iccount+2:iccount+2).eq.' ') then - iccount = iccount+2 - go to 110 -c+++ - end if -c -c End of xtup options. At this point symbol can only be note or rest -c - if (index('abcdefgr',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'In xtup, this character is not allowed!') - call stop1() - else if (durq.eq.'r' .and. itup.eq.ntup) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Sorry, PMX cannot end an xtuplet with a rest!') - call stop1() - end if -7 call g1etchar(lineq,iccount,durq) - if (index('2345678ulcb',durq) .gt. 0) then - go to 7 - else if (index('sfn',durq) .gt. 0) then -c -c Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift. -c - if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 - go to 7 - else if (index('+-<>',durq) .gt. 0) then -c -c May have either octave jump or shifted accid. on main xtup note -c - if (index('+-',durq).gt.0 .and. - * index('01234567890',lineq(iccount+1:iccount+1)).eq.0) - * go to 7 - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - go to 7 - else if (index('DF',durq) .gt. 0) then -c -c Double an xtup note to make an unequal xtup -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) - ndoub = ndoub+1 - go to 7 - else if (durq .eq. 'd') then - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) - go to 7 - else if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal option on xtuplet note!') - call stop1() - end if - if (itup .eq. ntup-ndoub) go to 3 -6 continue -3 continue -c -c 6==End of loop for xtuplet input -c - else if (durq .eq. 'm') then -c -c Multi-bar rest: next 1 or two digits are # of bars. -c - if (mod(itsofar(iv),lenbar) .ne. 0) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Multibar rest must start at beginning of bar!') - call stop1() - else if (iv.eq.1.and.ibarmbr.gt.0) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Multibar rest only OK at one time per block!') - call stop1() - end if -c -c For some purposes, pretend its one bar only -c - nodur(iv,nnl(iv)) = lenbar - ibarmbr = nbars+1 - mbrest = 0 -c20 call g1etchar(lineq,iccount,durq) - call g1etchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected an integer after "rm"!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - mbrest = nint(fnum) - iccount = iccount-1 -c if (ichar(durq).ge.48.and.ichar(durq).le.57) then -c mbrest = 10*mbrest+ichar(durq)-48 -c go to 20 -c end if - if (nv .gt. 1) then - if (iv .eq. 1) then - mbrestsav = mbrest - else - if (mbrest .ne. mbrestsav) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Must enter same multi-bar rest in every voice!') - call stop1() - end if - end if -c -c Zero out mbrestsav so can check at end of input block whether -c all voices have one -c - if (iv .eq. nv) mbrestsav=0 - end if - if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after "rm"!') - call stop1() - end if - else if (durq .eq. '.') then -c -c Dotted pattern. Close out note. Mult time by 3/4. -c Set time for next note to 1/4. Start the note. -c - idotform = 1 - else if (durq .eq. ',') then - idotform = 3 -c -c Now flow to duration setting, as if durq=' ' -c - else if (index('oL',durq) .gt. 0) then -c -c Suppress full bar rest, or look left for height -c - if (charq .ne. 'r') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"o","L" options only legal for rest, not note!') - call stop1() - end if - go to 2 - else if (index('DF',durq) .gt. 0) then -c -c Double note for xtup. Must check here in case "D" or "F" came before "x" or on -c last note of xtup. Need to flag it in pmxa since affects horiz. spacing. -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) - go to 2 - else if (durq .eq. 'A') then -c -c Main note accidental option -c - call getchar(lineq,iccount,durq) - if (index('o+-<>',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"o",+","-","<",">" are the only legal options here!') - call stop1() - end if -c -c Need more stuff here -c - if (durq .ne. "o") then -c -c Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will -c proceed to number input checking -c - iccount = iccount-1 - end if - go to 2 - else if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character!') - print*,'ASCII code:',ichar(durq) - call stop1() - end if -c -c End of block for note options. -c -c Set the duration -c - if (idotform .gt. 0) then - if (idotform .eq. 1) then - nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)*3/2 - else if (idotform .eq. 2) then - nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3 - else if (idotform .eq. 3) then - nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq) - else if (idotform .eq. 4) then - nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2 - end if - else if (ibarmbr.ne.nbars+1 .and. .not.fulbrp) then - nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq) -c -c Check for double dot -c - if (iddot .eq. 1) then - nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6 - iddot = 0 - end if - else if (fulbrp) then - nodur(ivx,nnl(ivx)) = lenbar -c -c Use a one-line function to set nnodur. It gives inverse of ifnodur. -c - nnodur = index('62514x0x37', - * chax(48+int(log(.1+lenbar)/.69315)))-1 - fulbrp = .false. - end if - rest(ivx,nnl(ivx)) = charq.eq.'r' -c -c If inside forced beam, check if note is beamable -c - if (fbon) then - if (nodur(ivx,nnl(ivx)) .lt. 16) go to 120 - if (nnl(ivx) .gt. 1) then - if (nodur(ivx,nnl(ivx)-1) .eq. 0) go to 120 - end if - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Unbeamable thing in forced beam!') - call stop1() - end if -120 continue -c -c Get number of prior bars for later check on whether note spans bar line -c - nbb4 = itsofar(ivx)/lenbar - itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) - if (mod(itsofar(ivx),lenbar) .eq. 0) then - nbars = nbars+1 - if (shifton) barend = .true. -c -c Will check barend when 1st note of next bar is entered. -c - if (nbars .gt. 15) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Cannot have more than 15 bars in an input block!') - call stop1() - end if - nib(ivx,nbars) = nnl(ivx) - if (firstline .and. lenbar.ne.lenbr1) then -c -c Just finished the pickup bar for this voice. -c - if (itsofar(ivx) .ne. lenbr0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Pickup bar length disagrees with mtrnum0!') - call stop1() - end if - lenbar = lenbr1 - itsofar(ivx) = 0 - end if - else if (barend) then - if (shifton) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Bar ended with user-defined shift still on!') - call stop1() - end if - barend = .false. - else if (itsofar(ivx)/lenbar .gt. nbb4) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'This note spans a bar line!') - call stop1() - end if - if (idotform.eq.1 .or. idotform.eq.3) then - call g1etchar(lineq,iccount,charq) - if (index('abcedfgr',charq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected note name or "r" here!') - call stop1() - end if - idotform = idotform+1 - numnum = 1 - go to 28 - end if -c -c End of sub block for note-rest -c - else if (charq .eq. 'z') then - call g1etchar(lineq,iccount,charq) - if (index('abcdefg',charq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected chord note name here!') - call stop1() - end if -25 call g1etchar(lineq,iccount,durq) -c if (index('dre12345678',durq) .gt. 0) then - if (index('dre12345678c',durq) .gt. 0) then - go to 25 - else if (index('fsn',durq) .gt. 0) then -c -c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so -c MUST come right after "f,s,n" -c - if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 - go to 25 - else if (durq .eq. 'A') then - if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Must have "f,s,n" before "A" in chord note!') - call stop1() - end if - go to 25 - else if (index('<>',durq) .gt. 0) then - if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then -c if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Must have "f,s,n,A" before "<" or ">"!') - call stop1() - end if - call g1etchar(lineq,iccount,durq) - if (index('1234567890.',durq) .eq. 0) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Expected a number to start here for accidental shift!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - go to 25 - else if (index('+-',durq) .gt. 0) then - if (index('1234567890.',lineq(iccount+1:iccount+1)) .eq. 0) - * go to 25 -c -c Number or '.' (durq) follows +/- . Get it. -c - call g1etchar(lineq,iccount,durq) - if (durq .eq. '.' .and. index('1234567890', - * lineq(iccount+1:iccount+1)) .eq. 0) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * '"." here must be followed by a digit!') - call stop1() - else if (index('sfndA',lineq(iccount-2:iccount-2)).eq.0) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Number after +/- must follow "d,s,f,n,A"!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - if (index('+-',durq) .eq. 0) then - iccount = iccount-1 - go to 25 - end if -c -c 2nd +/- -c - call g1etchar(lineq,iccount,durq) - if (durq .eq. '.') call g1etchar(lineq,iccount,durq) - if (index('1234567890',durq) .eq. 0) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Expected a number here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - go to 25 - else if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in chord note!') - call stop1() - end if - else if (charq .eq. 'G') then - ngr = 1 -9 call g1etchar(lineq,iccount,charq) - if (index('123456789',charq) .gt. 0) then - call readnum(lineq,iccount,durq,fnum) - ngr = nint(fnum) - iccount = iccount-1 - go to 9 - else if (index('AWulxs',charq) .gt. 0) then - go to 9 - else if (charq .eq. 'm') then - call g1etchar(lineq,iccount,charq) - if (index('01234',charq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'A digit less than 5 must follow "m" in a grace note!') - call stop1() - end if - go to 9 - else if (charq .eq. 'X') then -c -c Space before main note -c - call g1etchar(lineq,iccount,charq) - if (index('0123456789.',charq) .gt. 0) then - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - go to 9 - else - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'A number must follow "X" in a grace note!') - call stop1() - end if - end if -c -c At this point, charq is first note name in rest (grace?) -c - do 19 igr = 1 , ngr - numnum = 0 - if (igr .gt. 1) then -55 call g1etchar(lineq,iccount,charq) - if (charq .eq. ' ') go to 55 - end if - if (index('abcdefg',charq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'In grace, expected "a"-"g"!') - call stop1() - end if -18 call g1etchar(lineq,iccount,charq) - if (charq .ne. ' ') then - if (index('1234567',charq) .gt. 0) then - if (numnum .eq. 1) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Only one of "+-1234567" allowed here in grace!') - call stop1() - end if - numnum = 1 - go to 18 -c else if (index('nfs',charq) .gt. 0) then - else if (index('+-nfs',charq) .gt. 0) then - go to 18 - end if -c -c Digits are possible octave numbers -c - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after note name in grace!') - call stop1() - end if -19 continue - else if (charq .eq. chax(92)) then - call chklit(lineq,iccount,literr) - if (literr .gt. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * literq(literr)) - call stop1() - end if - else if (charq .eq. 'o') then -c -c Ornament on non-xtup note. "o" symbol must come AFTER the affected note -c - if (nnl(ivx) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"o" must be in same input block, after affected note!') - call stop1() - end if - call g1etchar(lineq,iccount,dumq) - if (index('(stmgx+Tupf._)e:>^bc',dumq) .eq. 0 ) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal ornament!') - call stop1() - end if - if (dumq .eq. ':') then - call g1etchar(lineq,iccount,dumq) - if (dumq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected blank after "o:"!') - call stop1() - else if (.not.ornrpt) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Turned off repeated ornaments before they were on!') - call stop1() - end if - ornrpt = .false. - else if (dumq .eq. 'g') then - if (issegno) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Sorry, only one "segno" per input block!') - call stop1() - else if (ivx .ne. 1) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'segno can only be in voice 1!') - call stop1() - end if - issegno = .true. -12 call g1etchar(lineq,iccount,dumq) - if (dumq.eq.'-' .or. - * (ichar(dumq).ge.48.and.ichar(dumq).le.58)) go to 12 - if (dumq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in segno ornament symbol!') - call stop1() - end if - else if (dumq .eq. 'T') then -c -c Trill. may be followed by 't' and/or number. read 'til blank -c -22 call g1etchar(lineq,iccount,dumq) - if (dumq .eq. ':') then - if (lineq(iccount+1:iccount+1) .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected blank after ":"!') - call stop1() - end if - go to 32 - else if (dumq .ne. ' ') then - go to 22 - end if - else if (dumq .eq. 'f') then - call g1etchar(lineq,iccount,dumq) - if (index(' d+-:',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after "f" in fermata ornament symbol!') - call stop1() - end if - if (dumq .eq. 'd') call g1etchar(lineq,iccount,dumq) - if (dumq .eq. ':') go to 32 - else if (dumq .eq. 'e') then - call g1etchar(lineq,iccount,dumq) - if (index('sfn?',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after "e" in edit. accid. symbol!') - call stop1() - end if - call g1etchar(lineq,iccount,dumq) - if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq) - else - call g1etchar(lineq,iccount,dumq) - end if - if (index('+- :',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in ornament symbol!') - call stop1() - end if - if (index('+-',dumq) .gt. 0) then - if (index('0123456789',lineq(iccount+1:iccount+1)).eq.0) then - call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, - * 'There should be an integer here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - if (durq .eq. ':') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Cannot shift AND repeat an ornament!') - call stop1() - end if -c -c 12/7/03 Allow horizontal shift on any ornament, not just breath and caes. -c - if (index('+-',durq) .gt. 0) then - if (index('.0123456789',lineq(iccount+1:iccount+1)) - * .eq. 0) then - call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, - * 'There should be a number here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - end if - end if -32 continue - if (dumq .eq. ':') then - if (lineq(iccount+1:iccount+1) .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '":" must be followed by blank in "o: "!') - call stop1() - else if (ornrpt) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Turned on repeated ornaments but already on!') - call stop1() - end if - ornrpt = .true. - end if - else if (index('st(){}',charq) .gt. 0) then - numint = 0 - iposn = 0 -8 call g1etchar(lineq,iccount,dumq) - iposn = iposn+1 - if (charq.eq.'t' .and. dumq.eq.'t') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Cannot use "t" as an option on a tie!') - call stop1() - end if - if (index('udltb+-fnhHps ',dumq) .eq. 0) then -c -c Check for explicit ID code. -c - ic = ichar(dumq) - if (ic.lt.48 .or. (ic.gt.57.and.ic.lt.65) .or. - * ic.gt.90) then -c -c Not 0-9 or A-Z, so exit -c - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in slur symbol!') - call stop1() - else -c -c It is a possible ID code. Right place? -c - if (iposn .ne. 1) then -c -c Slur ID is not 2nd! -c - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Slur ID must be second character in slur symbol!') - call stop1() - else if (charq.eq.'t' .and. fontslur) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Slur ID not allowed on non-postscript tie!') - call stop1() - end if - end if -c -c Slur ID is OK. Note it cannot be "H" at this point.. -c - go to 8 - else if (dumq .eq. 'H') then - if (iposn .eq. 1) go to 8 -c -c "H" is NOT an ID code. -c - if (.not.fontslur .and. charq.eq.'t') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Cannot reshape postscript ties this way!') - call stop1() - end if - if (lineq(iccount+1:iccount+1) .eq. 'H') then - iccount=iccount+1 - iposn = iposn+1 - end if - go to 8 - else if (index('fh',dumq).gt.0 .and. .not.fontslur - * .and. charq.eq.'t') then -c -c 3/9/03 Can't reshape postscript tie. -c - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Cannot reshape postscript ties this way!') - call stop1() - else if (dumq .eq. 'p') then -c -c local change in postscript slur/tie adjustment default -c - if (fontslur) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Must use postscript slurs ("Ap") to use this option!') - call stop1() - end if - call g1etchar(lineq,iccount,dumq) - if (index('+-',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected "+" or "-" here!') - call stop1() - end if - call g1etchar(lineq,iccount,dumq) - if (index('st',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected "s" or "t" here!') - call stop1() - end if - iposn = iposn+2 - go to 8 - end if - if (index('udltbfnh',dumq) .gt. 0) then - go to 8 - else if (index('+-',dumq) .gt. 0) then - numint = numint+1 - if (fontslur .and. charq.eq.'t') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"+|-" for slur height only allowed in "s"-slurs!') - call stop1() - end if - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - if (numint .eq. 1) then - if (nint(fnum) .gt. 30) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Magnitude of slur height adjustment cannot exceed 30!') - call stop1() - end if - else if (numint .eq. 2) then - if (abs(fnum) .gt. 6.3) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Slur horiz shift must be in range (-6.3,6.3)!') - call stop1() - end if - else -c -c Third signed integer, must be a midslur or curve spec. -c - if (abs(fnum).gt.31) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Slur midheight must be in the range (-31,31)!') - call stop1() - end if - if (durq .eq. ':') then -c -c Expecting curve parameters. Get two numbers -c - do 41 i = 1 , 2 - iccount = iccount+1 - fnum = ichar(lineq(iccount:iccount))-48 - if (abs(fnum-3.5) .gt. 3.6) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Slur curve parameter must be in range (0,7)!') - call stop1() - end if -41 continue - iccount = iccount+1 - end if - end if - iccount = iccount-1 - go to 8 - else if (dumq .eq. 's') then -c -c What follows should be one or two signed numbers for adjustment of line break -c slur, end of 1st segment or start of second. -c - if (fontslur) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'May not use linebreak slur options with font-based slurs!') - call stop1() - end if - call g1etchar(lineq,iccount,dumq) - if (index('+-',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'This character must be "+" or "-"!') - call stop1() - end if - iccount = iccount+1 - call readnum(lineq,iccount,dumq,fnum) - if (nint(fnum) .gt. 30) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Magnitude of slur height adjustment cannot exceed 30!') - call stop1() - end if - if (index('+-',dumq) .gt. 0) then - iccount = iccount+1 - call readnum(lineq,iccount,dumq,fnum) - if (abs(fnum) .gt. 6.3) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Slur horiz shift must be in range (-6.3,6.3)!') - call stop1() - end if - end if - iccount = iccount-1 - go to 8 - else if (dumq .eq. 'H' .and. iposn.gt.1) then - if (lineq(iccount+1:iccount+1) .eq. 'H') iccount=iccount+1 - go to 8 - end if - else if (charq .eq. '?') then - call getchar(lineq,iccount,durq) - if (durq .eq. ' ') then - iccount = iccount-1 - else - if (durq .ne. '-') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expecting "-"!') - call stop1() - end if - call getchar(lineq,iccount,durq) - if (index('0123456789.',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expecting number!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - end if - else if ((ichar(charq).ge.48.and.ichar(charq).le.57) .or. - * index('#-nx_',charq) .gt. 0) then -c -c We have a figure. Must come AFTER the note it goes under -c - if (itsofar(ivx).eq.0 .and. - * (.not.firstline.or.lenbr0.eq.0.or.lenbar.eq.lenbr0)) then -c -c Figure before first note in block -c - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Cannot put figure before first note in block!') - call stop1() - end if - if (charq.eq.'x') then - indxb = index(lineq(iccount:128),' ') - if (indxb .lt. 5) then - call errmsg(lineq,iccount+indxb-1,ibarcnt-ibaroff+nbars+1, - * 'Cannot have a blank here in floating figure!') - call stop1() - end if - end if - if (usefig) ifig = 1 -5 call g1etchar(lineq,iccount,charq) - if (index(' 0123456789#-nx_.:+s',charq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in figure!') - call stop1() - else if (charq .eq. '+') then -c -c vertical offset, must be integer, then blank -c - call g1etchar(lineq,iccount,charq) - if (index('123456789',charq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Integer for vertical offset expected here!') - call stop1() - end if - call readnum(lineq,iccount,charq,fnum) - if (charq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Vertical offset must terminate figure!') - call stop1() - end if - iccount = iccount-1 - go to 5 - else if (charq .eq. 's') then - isligfont = .true. - end if - if (charq .ne. ' ') go to 5 - else if (charq .eq. '[') then - if (fbon) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Started forced beam while another was open!') - call stop1() - end if - fbon = .true. -17 call g1etchar(lineq,iccount,charq) - if (index('uljhf:',charq) .gt. 0) then - go to 17 - else if (index('+-',charq) .gt. 0) then - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - go to 17 - else if (charq .eq. 'm') then -c -c Forced multiplicity, next char should be 1-4 -c - call g1etchar(lineq,iccount,charq) - if (index('1234',charq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Forced multiplicity for a beam must be 1, 2, 3, or 4!') - call stop1() - end if - go to 17 - else if (charq .ne. ' ') then - if (index('0123456789',charq) .gt. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'After "[", digits must now be preceeded by "+" or "-"!') - print*,'You will have to edit older sources to meet this rqmt,' - print*,'but it was needed to allow 2-digit height adjustments.' - print*,'Sorry for the inconvenience. --The Management' - else - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after [!') - end if - call stop1() - end if - else if (charq .eq. ']') then - if (.not.fbon) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Forced beam stop with no corresponding start!') - call stop1() - end if - call g1etchar(lineq,iccount,charq) - if (charq .eq. '-') then - if (lineq(iccount+1:iccount+2) .ne. '[ ') then - call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, - * 'Only sequence allowed here is "[ "!') - call stop1() - else - iccount = iccount+2 - end if - else if (charq .eq. '[') then - if (lineq(iccount+1:iccount+1) .ne. ' ') then - call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, - * 'This character must be a blank!') - call stop1() - end if - else -c -c Forced beam is really ending -c - fbon = .false. - if (charq .eq. 'j') then - if (lineq(iccount+1:iccount+1) .ne. ' ') then - call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, - * 'This character must be a blank!') - call stop1() - end if - else if (charq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"]" must be followed by blank, "j", "-", or "["!') - call stop1() - end if - end if - else if (charq .eq. 'D') then -c -c Dynamic mark -c - if (nnl(ivx) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"D" must not come before any notes have been entered!') - call stop1() - end if - call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1) - else if (index('lhw',charq) .gt. 0) then -c -c Save position for later check -c - icclhw = iccount - call g1etchar(lineq,iccount,durq) - if (index('0123456789.+- ',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after "l", "w", or "h"!') - call stop1() - end if - isheadr = isheadr .or. charq .eq. 'h' - if (index(' +-',durq) .gt. 0) then -c -c There is a header (or lower string?) -c - if (index('+-',durq) .gt. 0) then -c -c User-defined vert offset (\internote). -c - if (charq .ne. 'h') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"+" or "-" not permitted here!') - call stop1() - end if -c -c Have "h" followed by +/- . Check for digit. -c Can blow durq since not using fnum for now, but... -c - call g1etchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'There must be a digit here!') - call stop1() - end if -c -c Have "h" followed by +/- followed by a digit. No need to get the number. -c -c call readnum(lineq,iccount,durq,fnum) - end if - if (charq .ne. 'w') then -c -c Header or lower string. -c - if (icclhw .ne. 1) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * '"h" or "l" must be first character in line!') - call stop1() - end if -c -c Read past the next line, which has the string. -c - call read10(charq,lastchar) - nline = nline+1 - iccount = 128 - else - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Symbol "w" (width) must be followed by a digit!') - call stop1() - end if - else -c -c Height or width change spec. Check if at start of piece. -c - if (ibarcnt .gt. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Symbol must go at top of first input block!') - call stop1() - end if - call readnum(lineq,iccount,durq,dimen) -c -c Check units. Convert to points -c - if (durq .eq. ' ' .or. durq .eq. 'p') then - dimen = dimen+.5 - else if (durq .eq. 'i') then - dimen = dimen*72+.5 - else if (durq .eq. 'm') then - dimen = dimen/25.4*72+.5 - else - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal unit; must be "p","i",or"m"!') - call stop1() - end if - if (charq .eq. 'h') then - ptheight = int(dimen) - else - widthpt = int(dimen) - end if - end if - else if (charq .eq. 'm') then -c -c Time signature change. Only allow at beginning of block. -c mtrnuml, mtrdenl (logical) and p (printable) will be input. -c mtrnuml=0 initially. (In common) -c -c Check whether at beginning of a block -c - if (ivx.ne.1 .or. nnl(1).ne.0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Meter change only OK in voice 1, at start of block!') - print*,'voice number is',ivx - call stop1() - end if - newmeter = .true. - call readmeter(lineq,iccount,mtrnuml,mtrdenl) - if (mtrnuml .eq. 0) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Digit 0 not allowed here!') - call stop1() -c else if (mtrdenl .eq. 1) then -cc -cc Kluge!!! -cc -c mtrdenl = 2 -c mtrnuml = 2*mtrnuml - end if - call readmeter(lineq,iccount,mtrnmp,mtrdnp) -c -c Read past printed time signature; not used in pmxa. -c - lenbeat = i1fnodur(mtrdenl,'x') - lenmult = 1 - if (mtrdenl .eq. 2) then - lenbeat = 16 - lenmult = 2 - end if - lenbar = lenmult*mtrnuml*lenbeat - mtrnuml = 0 - else if (charq .eq. 'C') then - call g1etchar(lineq,iccount,durq) - if (.not.(index('tsmanrbf',durq).gt.0 .or. -c * (ichar(durq).ge.48 .and. ichar(durq).le.54))) then - * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, -c * 'Must have t,s,m,a,n,r,b,f or 1-6 after C!') - * 'Must have t,s,m,a,n,r,b,f or 1-7 after C!') - call stop1() - end if - gotclef = .true. - else if (charq .eq. 'R') then - if (ivx .ne. 1) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Repeats can only go in voice 1!') - call stop1() - end if -10 call g1etchar(lineq,iccount,durq) - if (index('lrdDbz',durq) .gt. 0) go to 10 - if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after "R" (repeat/double bar)!') - call stop1() - end if - else if (charq .eq. 'V') then -c -c Ending -c - if (iv .ne. 1) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Voltas are only allowed in voice #1!') - call stop1() - else if (isvolt) then - print* - print*,'*******WARNING********' - write(15,'(/,a)')'*******WARNING********' - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'There is more than one volta in this input block.!') - print*,'This may work in a score, but WILL NOT work in parts.' - print*, - *'Safest to have only 1 volta per block, at the start of the block' - write(15,'(a)') - * 'This may work in a score, but WILL NOT work in parts.' - write(15,'(a)') - *'Safest to have only 1 volta per block, at the start of the block' - end if - isvolt = .true. - lvoltxt = 0 -11 call g1etchar(lineq,iccount,durq) - if (durq .ne.' ') then - go to 11 - end if - else if (charq .eq. 'B') then - continue - else if (charq .eq. 'P') then - if (ivx.ne.1 .or. nnl(1).ne.0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Only allowed at beginning of block!') - call stop1() - end if -16 call g1etchar(lineq,iccount,durq) - if (durq.eq.'l'.or.durq.eq.'r'.or.(ichar(durq).ge.48 .and. - * ichar(durq).le.57)) go to 16 - if (durq .eq. 'c') then -c -c Expect a centered name, and it has to be last option -c - call g1etchar(lineq,iccount,durq) - if (durq .eq. '"') then -c -c Quoted name, go to next quote mark -c - do 35 iccount = iccount+1 , 127 - if (lineq(iccount:iccount) .eq. '"') go to 36 -35 continue - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Missing close quote after page number command (P)!') - call stop1() -36 continue - else if (durq .ne. ' ') then -c -c Space-delimited name, look for next blank -c - do 37 iccount = iccount+1 , 127 - if (lineq(iccount:iccount) .eq. ' ') go to 38 -37 continue -38 continue - end if - else if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Only "l","r","c" or digit allowed after "P"!') - call stop1() - end if - else if (charq .eq. 'W') then - call g1etchar(lineq,iccount,durq) - if (index('.0123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected a number to start here!') - call stop1() - end if - call readnum(lineq,iccount,durq,wminnh(ibarcnt+nbars+1)) - else if (charq .eq. 'T') then -c -c Titles -c - call g1etchar(lineq,iccount,durq) - if (index('itc',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Must put "i", "t", or "c" after "T"!') - call stop1() - end if - ihead = ihead+2**(index('itc',durq)-1) -c -c Maybe a number after 'Tt', but ignore here. Read past string on next line. -c - call read10(charq,lastchar) - nline = nline+1 - iccount = 128 - else if (charq .eq. 'A') then -27 call g1etchar(lineq,iccount,durq) - if (index('rbsdeK',durq) .gt. 0) then - go to 27 - else if (durq .eq. 'v') then - if (ibarcnt .eq. 0) novshrinktop = .true. - go to 27 - else if (durq .eq. 'a') then - call g1etchar(lineq,iccount,durq) - call readnum(lineq,iccount,durq,fbar) - iccount = iccount-1 - go to 27 - else if (durq .eq. 'i') then - call g1etchar(lineq,iccount,durq) -c -c Local interstaff correction. Set to -1. if not specifiec, or after use, -c or anytime except at top, since pmxb handles all times except at top. -c - call readnum(lineq,iccount,durq,tintstf) - if (ibarcnt .eq. 0) fintstf = tintstf - iccount = iccount-1 - go to 27 - else if (durq .eq. 'I') then -c -c Global interstaff correction. Use in place of fintstf if fintstf<0 -c - call g1etchar(lineq,iccount,durq) - call readnum(lineq,iccount,durq,gintstf) - iccount = iccount-1 - go to 27 - else if (durq .eq. 'o') then - optimize = .true. - go to 27 - else if (durq .eq. 'S') then - do 50 iiv = 1 , nv - call g1etchar(lineq,iccount,durq) - if (index('-0st',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'After "AS", need nv instances of "s,t,-,0"!') - call stop1() - end if - if (durq.eq.'-'.or.durq.eq.'s') then - isize(iiv) = 1 - else if (durq.eq.'t') then - isize(iiv) = 2 - end if -50 continue - go to 27 - else if (durq .eq. 'p') then - fontslur = .false. -42 continue - call g1etchar(lineq,iccount,durq) - if (index('+-',durq) .gt. 0) then -c -c Characters to change defaults for ps slurs -c - call g1etchar(lineq,iccount,durq) - if (index('shtc',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Only letters allowed here are "s","h","t","c"!') - call stop1() - end if -c -c Now check for another default modifier -c - go to 42 - else if (index('lh',durq) .gt. 0) then -c -c Flags for optional linebreak ties or header specials -c - go to 42 - else - iccount = iccount-1 - end if - go to 27 - else if (durq .eq. 'N') then -c -c Override default name for a part file. Must have part number, then -c partname in quotes. Must be on line by itself, and start in column 1. -c Will only be passed thru to scor2prt. -c - if (iccount .ne. 2) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"AN" must start in column 1!') - call stop1() - end if - ndxquote = index(lineq,'"') - if (ndxquote.lt.4 .or. ndxquote.gt.5 .or. - * index('123456789',lineq(3:3)).eq.0 .or. - * (ndxquote.eq.5.and.index('012',lineq(4:4)).eq.0)) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"AN" must be followed by inst. #, then quote!') - call stop1() - end if - ndxquote = index(lineq(ndxquote+1:128),'"') - if (ndxquote .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'In "AN", file name must be in quotes!') - call stop1() - end if - iccount = 128 - else if (durq .eq. 'T') then - cstuplet = .true. - else if (durq .eq. 'R') then -c -c Get full name of normal include file; must occupy remainder of line -c - call getpmxmod(.false.,lineq(iccount+1:128)) - iccount = 128 - else if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, -c * 'After "A" must follow one of the letters abdeiINprsST!') - * 'After "A" must follow one of the letters abdeiINprRsST!') - call stop1() - end if - else if (charq .eq. 'K') then -c -c Rules and function of K command -c -c Only 1 K +/-n +/-m allowed per block if n.ne.0 (transposition). isig1 is -c initial sig, and must be passed to pmxb because it is needed when topfile -c is called, which is before the K+n+m command is read in pmxb. Also, we -c compute and save ibrkch and newkey for each syst, accounting for key changes, -c then adjust fbar to make poenom much more accurate. -c Jan 02: Now K-0+[n] is used to transpose e.g. from f to f#. -c - call g1etchar(lineq,iccount,durq) - if (index('+-i',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"K" (transpose or key change) must be followed by "+,-,i"!') - call stop1() - end if - if (durq .ne. 'i') then -c -c Normal key change and/or transposition) -c -c iccount = iccount+1 - num1 = 44-ichar(durq) -c -c num1= +1 or -1 -c - ztrans = num1.eq.-1 - call g1etchar(lineq,iccount,durq) - if (index('0123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '1st +/- must be followed by a number!') - call stop1() - end if -c iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - num1 = nint(fnum)*num1 - ztrans = ztrans .and. num1.eq.0 - if (index('+-',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '1st number after "K" must be followed by "+,-"!') - call stop1() - end if - iccount = iccount+1 - num2 = 44-ichar(durq) - call readnum(lineq,iccount,durq,fnum) - num2 = num2*int(fnum+.1) - if (num1.eq.0 .and. .not.ztrans) then -c -c Key change, only one per block allowed -c - if (iskchb) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Only one key change allowed per input block!') - call stop1() - end if - iskchb = .true. - nkeys = nkeys+1 - kchmid(nkeys) = mod(itsofar(ivx),lenbar).ne.0 -c -c Make ibrkch = barnum-1 if at start of bar, so fsyst advances ok at linebreak. -c - ibrkch(nkeys) = ibarcnt+nbars - if (kchmid(nkeys)) ibrkch(nkeys) = ibrkch(nkeys)+1 - newkey(nkeys) = num2+idsig - else -c -c Transposition -c - fulltrans = .true. - if (ibarcnt .gt. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Transposition must be at top of first input block!') - call stop1() - end if - isig1 = num2 - idsig = isig1-newkey(1) -c -c idsig is the difference between sig after transposition, and sig in setup. -c It may alter # of accid's in key changes if there is transposition. -c - end if - else ! durq='i' -c -c 110522/110529 -c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] -c and repeat i[...] for multiple instruments. Store info here if ibarcnt=0 -c so can pass to topfile (via comInstTrans), which is called before getnote. -c Otherwise, will store info from getnote. Initialize EarlyTransOn and -c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from here; -c LaterInstTrans from g1etnote. Zero both out after use. nInstTrans really -c only needed for instrument-signatures, not transpositions. iTransAmt is -c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for -c each staff. -c -c if (fulltrans) then -c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, -c * 'Cannot yet combine full and instrument transposition!') -c call stop1() -c end if - call GetiTransInfo(.true.,ibarcnt,lineq,iccount, - * ibaroff,nbars,noinst,iv) - end if - else if (charq .eq. '|') then -c -c Optional bar symbol -c - if (mod(itsofar(ivx),lenbar).ne.0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Bar line marker out of place!') - call stop1() - else if (shifton) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Bar ended with user-defined shift still on!') - call stop1() - end if - else if (charq .eq. '/') then - if (ornrpt) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'WARNING: Block ended with repeated ornament still on!') - ornrpt = .false. - end if - if (stickyS) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'WARNING: Block ended with sticky stemshrink still on!') - stickyS = .false. - end if - if (fbon) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Block ended with forced beam open!') - call stop1() - else if (shifton) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Bar ended with user-defined shift still on!') - call stop1() - else if (gotclef) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'May not enter clef at end of input block!') - call stop1() - end if - barend = .false. -c -c Perform time checks -c - if (mod(itsofar(ivx),lenbar).ne.0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Block duration not divisible by lenbar!') - print*,'lenbar is ',lenbar - call stop1() - else if (ivx.gt.1 .and. itsofar(ivx).ne.itsofar(1)) then - print* - print*,'# of bars in voice 1, current voice:', - * itsofar(1)/lenbar,itsofar(ivx)/lenbar - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Block duration not equal to voice 1!') - call stop1() - end if - call g1etchar(lineq,iccount,durq) - if (durq .eq. ' ' .and. iv.eq.nv) then -c -c End of input block -c - loop = .false. - else -c -c Start a new voice -c - if (lenbr0.ne.0 .and. firstline) lenbar = lenbr0 - nbars = 0 - if (durq .eq. ' ') then -c -c New voice is on next staff -c - iv = iv+1 - ivx = iv - else -c -c New voice is on same staff. Set up for it -c - ivx = nv+1 - do 23 iiv = 1 , nv - if (nvmx(iiv) .eq. 2) ivx = ivx+1 -23 continue - if (ivx .gt. nm) then - write(*,'(1x,a21,i3,a23)')'Cannot have more than',nm, - * ' lines of music at once' - call stop1() - end if - nvmx(iv) = 2 - ivmx(iv,2) = ivx - itsofar(ivx) = 0 - nnl(ivx) = 0 - do 24 j = 1 , 200 - rest(ivx,j) = .false. - nacc(ivx,j) = 0 -24 continue -c -c For midi stuff, record that there is a 2nd line of music in this voice -c - if (ismidi) twoline(iv) = .true. - end if - end if - iccount = 128 - else if (charq .eq. 'S') then -c -c New nsyst: for use with partmaker scor2prt, for parts w/ diff # of systs. -c - if (ibarcnt .gt. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"S" can only be in first input block!') - call stop1() - end if - call g1etchar(lineq,iccount,durq) - if (index('123456789 ',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'A digit must follow "S"!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnsyst) - nsyst = nint(fnsyst) -14 continue - if (durq .eq. 'P') then -c -c New npages for parts. -c - call g1etchar(lineq,iccount,durq) - if (index('123456789 ',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Must have a number here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnsyst) - npages = nint(fnsyst) - go to 14 - else if (durq .eq. 'm') then -c -c Reset musize (musicsize). -c - call g1etchar(lineq,iccount,durq) - if (index('123456789 ',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Must have a number here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnsyst) - musize = nint(fnsyst) - wheadpt = whead20*musize - go to 14 - else if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in "S" symbol!') - call stop1() - end if - else if (charq .eq. 'L') then - nflb = nflb+1 - ibarflb(nflb) = ibarcnt+nbars+1 - call g1etchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Need integer to define forced line break!') - call stop1() - end if - call readnum(lineq,iccount,durq,sysflb) - isysflb(nflb) = nint(sysflb) - if (nflb .gt. 1) then -c -c Check if new number is > prior one -c - if (isysflb(nflb) .le. isysflb(nflb-1)) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'You already forced a line break at a later line!') - call stop1() - end if - end if - if (npages .eq. 0) then - print* - print*,'WARNING! You forced a line break at line ', - * isysflb(nflb),' but npage = 0. Continue?' - read(*,'(a)') charq - if (index('yY',charq) .eq. 0) call stop1() - else if (isysflb(nflb) .gt. nsyst) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Forced line break at line num > nsyst!') - call stop1() - else if (index(' PM',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Must have " ", "P", or "M" here!') - call stop1() - end if - if (durq .eq. 'P') then -c -c Forced page break here, get page number. -c - call g1etchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Need integer to define forced page break!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - nfpb = nfpb+1 - ipagfpb(nfpb) = nint(fnum) - isysfpb(nfpb) = isysflb(nflb) - if (ipagfpb(nfpb) .gt. npages) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Forced page break at page num > npages!') - call stop1() - else if (nfpb .gt. 1) then - if (ipagfpb(nfpb) .le. (ipagfpb(nfpb-1))) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Forced page break numbers must increase!') - call stop1() - end if - end if - end if - if (index(' M',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in linebreak symbol!') - call stop1() - else if (durq .eq. 'M') then - nmovbrk = nmovbrk+1 - isysmb(nmovbrk) = isysflb(nflb) - call g1etchar(lineq,iccount,durq) -31 if (durq .eq. '+') then -c -c Vertical spacing, read past number. -c - call g1etchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Integer required here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - go to 31 - else if (durq .eq. 'i') then -c -c Change indentation, -c - call g1etchar(lineq,iccount,durq) - if (index('.123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Decimal number required here!') - call stop1() - end if -c -c fracsys was initialized in block data to all 0.'s -c - call readnum(lineq,iccount,durq,fracsys(nmovbrk)) - go to 31 - else if (durq .eq. 'c') then - call g1etchar(lineq,iccount,durq) - go to 31 - else if (durq .eq. 'r') then - call g1etchar(lineq,iccount,durq) - if (index('+-',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Must have "+" or "-" after "r" as movement break option!') - call stop1() - end if - call g1etchar(lineq,iccount,durq) - go to 31 - else if (durq .eq. 'n') then -c -c Change # of voices. Input ninow, iorig(1...ninow). Will use names, -c staves per inst. and clefs corr. to iorig in original list of instruments. -c - nv = 0 - call g1etchar(lineq,iccount,durq) - if (durq .eq. ':') then -c -c Signals a 2-digit number, get next two characters -c - call g1etchar(lineq,iccount,durq) - call g1etchar(lineq,iccount,dumq) - if (index('12',durq).eq.0 - * .or.index('0123456789',dumq).eq.0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal new number of instruments '//durq//dumq// - * ' at movement break!') - call stop1() - end if - read(lineq(iccount-1:iccount),'(i2)')ninow - else -c -c durq is a single digit number for noinow -c - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal new number of instruments '//durq// - * ' at movement break!') - call stop1() - end if - ninow = ichar(durq)-48 - end if - if (ninow.gt.noinst) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'New number of instruments must be <= original!') - call stop1() - end if - do 63 iinow = 1 , ninow - call g1etchar(lineq,iccount,durq) - if (durq .eq. ':') then -c -c Signals a 2-digit number -c - call g1etchar(lineq,iccount,durq) - call g1etchar(lineq,iccount,dumq) - if (index('12',durq).eq.0 - * .or.index('0123456789',dumq).eq.0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal 2-digit instrument number '//durq//dumq// - * ' at movement break!') - call stop1() - end if - read(lineq(iccount-1:iccount),'(i2)')iorig - else -c -c durq is a single digit number for iorig -c - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal instrument number '//durq// - * ' at movement break!') - call stop1() - end if - iorig = ichar(durq)-48 - end if - if (iorig .gt. noinst) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'New instrument number must be <= original noinst!') - call stop1() - end if - nv = nv+nsperi(iorig) -63 continue - do 61 iiv = 1 , nv -c -c Get clef names -c - call g1etchar(lineq,iccount,durq) - if (.not.(index('tsmanrbf',durq).gt.0 .or. - * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Must have t,s,m,a,n,r,b,f or 1-7 as clef symbol here!') - call stop1() - end if -c -c Initialize new voices -c - nvmx(iiv) = 1 - ivmx(iiv,1) = iiv - itsofar(iiv) = 0 - nnl(iiv) = 0 - do 62 j = 1 , 200 - rest(iiv,j) = .false. -62 continue -61 continue -c -c Loop back up, this might not be last option in M -c - call g1etchar(lineq,iccount,durq) - go to 31 - else if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after Movement break symbol!') - call stop1() - end if - if (fracsys(nmovbrk) .lt. 0.001) then -c -c Since fracsys was not explicitly set, set it to prior value. -c - if (nmovbrk .eq. 1) then - fracsys(nmovbrk) = fracindent - else - fracsys(nmovbrk) = fracsys(nmovbrk-1) - end if - end if - end if -c -c Just before exiting if-block for forced line breaks, set counter to use when -c dealing with vertical space calcs -c - nistaff(nflb) = nv-1 - else if (charq .eq. 'F') then - usefig = .false. - else if (charq .eq. 'X') then - call g1etx(lineq,iccount,.true.,shifton,ibarcnt-ibaroff+nbars+1, - * udsp(ibarcnt+nbars+1),wheadpt) - else if (charq .eq. 'I') then -c -c MIDI settings. -c - if (ivx.ne.1 .or. nnl(1).ne.0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'MIDI stuff only allowed at start of block!') - call stop1() - end if - if (nv .gt. 15) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Sorry but MIDI does not work with more than 15 voices!') - call stop1() - end if - ismidi = .true. - call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, - * mtrdenl,.true.) - else if (charq .eq. 'M') then - call setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,ivx, - * nline) - else if (index(',.',charq) .gt. 0) then -c -c Continued rhythmic shortcut -c - idotform = index('. ,',charq) - if (idotform .eq. 1) then -c -c Change duration of prior note -c - itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx)) - nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2 - itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) - end if - idotform = idotform+1 - numnum = 1 - cdot = .true. - go to 1 - else - print*,'ASCII code:',ichar(charq) - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'This character is not allowed here!') - print*,'ASCII code:',ichar(charq) - call stop1() - end if - return - end - subroutine g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, - * xmtrnum0,newkey,npages,nsyst,musize,bottreb) - parameter(nm=24,maxblks=4000) - character*65536 bufq - character*1 chax - integer*2 lbuf(maxblks) - common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq - character*128 lineq - logical lastchar,issegno,isheadr,isvolt,fbon,bottreb, - * newway - common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, - * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 -c -c Get the first line -c - iccount = 0 - nline = 1 -9 call getbuf(lineq) - if (lineq(1:1) .eq. '%') then - nline = nline+1 - go to 9 - end if - if (lineq(1:3) .eq. '---') then -c -c Have TeX input until next line that starts with '---' -c -3 nline = nline+1 - call getbuf(lineq) - if (ilbuf .gt. nlbuf) go to 1 - go to 2 -1 print*,'You did not terminate type 0 TeX input with "---"' - call stop1() -2 continue - if (lineq(1:3) .ne. '---') go to 3 -c -c Force a new line read on first call to readin -c - iccount = 128 - end if -c -c Here, lineq and nline are first non-TeX lines. -c - nv = nint(readin(lineq,iccount,nline)) - if (nv .gt. nm) then - write(*,'(1x,a46,i3)') - * 'In setup data, number of voices cannot exceed',nm - call stop1() - end if - noinst = nint(readin(lineq,iccount,nline)) - if (noinst .gt. nv) then - write(*,'(a)') - * 'In setup data, cannot have more instruments than staves' - call stop1() - end if - newway = noinst.le.0 - if (newway) noinst = -noinst - do 10 iinst = 1 , noinst -c -c Seve # of staves per inst in case later drop some inst's. -c - if (newway) then - nsperi(iinst) = nint(readin(lineq,iccount,nline)) - else if (iinst .gt. 1 ) then - nsperi(iinst) = 1 - else - nsperi(iinst) = nv-noinst+1 - end if -10 continue - mtrnuml = nint(readin(lineq,iccount,nline)) - mtrdenl = nint(readin(lineq,iccount,nline)) -cc -cc Kluge!!! -cc -c if (mtrdenl .eq. 1) then -c mtrdenl = 2 -c mtrnuml = mtrnuml*2 -c end if - mtrnmp = nint(readin(lineq,iccount,nline)) - mtrdnp = nint(readin(lineq,iccount,nline)) - if (mtrnmp.eq.0 .and. mtrdnp .ge. 8) then - write(*,'(a)')'In setup data, with mtrnmp=0, mtrdnp must be <8' - call stop1() - end if - xmtrnum0 = readin(lineq,iccount,nline) - newkey = nint(readin(lineq,iccount,nline)) - npages = nint(readin(lineq,iccount,nline)) - nsyst = nint(readin(lineq,iccount,nline)) - musize = nint(readin(lineq,iccount,nline)) - fracindent = readin(lineq,iccount,nline) - if (fracindent .ge. 1.) then - write(*,'(a)')'In setup data, fracindent must be <1' - call stop1() - end if - if (npages .gt. nsyst) then - print*,'Error in input file: npages > nsyst' - call stop1() - else if((musize-16)*(musize-20)*(musize-24)*(musize-29).ne.0) then - call printl('Musicsize must be 16, 20, 24, or 29') - call stop1() - end if -c -c Next noinst non-comment lines are names of instruments. -c - do 4 i = 1 , abs(noinst) -5 call getbuf(lineq) - nline = nline+1 - if (lineq(1:1) .eq. '%') go to 5 -4 continue -c -c Mext non-comment line has nv clef names -c -6 call getbuf(lineq) - nline = nline+1 - if (lineq(1:1) .eq. '%') go to 6 - do 7 iv = 1 , nv -c if (index('brnamstf0123456',lineq(iv:iv)) .eq. 0) then - if (index('brnamstf01234567',lineq(iv:iv)) .eq. 0) then - call errmsg(lineq,iv,0, - * 'There should be a clef symbol here!') - call stop1() - end if -7 continue - if (lineq(nv+1:nv+1) .ne. ' ') then - call errmsg(lineq,nv+1,0, - * 'There should be a blank here!') - call stop1() - end if -c -c Set flag if voice 1 is treble, since it affects vertical spacing -c - bottreb = lineq(1:1).eq.'t' -c -c Mext non-comment line has path name -c -8 call getbuf(lineq) - nline = nline+1 - if (lineq(1:1) .eq. '%') go to 8 - lpath = index(lineq,' ')-1 - if (index('/:'//chax(92),lineq(lpath:lpath)) .eq. 0) then - call errmsg(lineq,lpath,0, - * 'Last character of pathname is not "/",":", or "' - * //chax(92)//'"!') - call stop1() - end if - return - end - subroutine g1etx(lineq,iccount,notxtup,shifton,ibar,udsp,wheadpt) -c -c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. -c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. -c - logical notxtup,shifton,number,btest - character*128 lineq - character*1 charq,dumq - number = .false. - nPBSc = 0 -1 call g1etchar(lineq,iccount,charq) - if (index('PBS:',charq) .gt. 0) then -c -c Continue checking here even if "P". -c - ipbsc = index('PBS:',charq) - if (btest(nPBSc,ipbsc)) then - call errmsg(lineq,iccount,ibar,'Only one allowed per symbol!') - call stop1() -c else if (.not.notxtup .and. ipbsc.gt.2) then -c call errmsg(lineq,iccount,ibar,'Not allowed in xtuplet!') -c call stop1() - end if - nPBSc = ibset(nPBSc,ipbsc) - go to 1 - else if (index('+-.0123456789',charq) .gt. 0) then - number = .true. - if (index('+-',charq) .gt. 0) then - call g1etchar(lineq,iccount,dumq) - if (index('.0123456789',dumq) .eq. 0) then - call errmsg(lineq,iccount,ibar,'Expected a number here!') - call stop1() - end if - end if - call readnum(lineq,iccount,dumq,fnum) - if (charq.eq.'-') fnum = -fnum - if (dumq .ne. 'p') then - iccount = iccount-1 - fnum = fnum*wheadpt - end if - go to 1 - else if (charq .ne. ' ') then - call errmsg(lineq,iccount,ibar,'Not allowed in "X" symbol!') - call stop1() - end if -c -c Done with parsing. Other checks -c - if (iand(6,nPBSc).eq.6 .or. iand(24,nPBSc).eq.24) then - call errmsg(lineq,iccount-1,ibar, - * 'Cannot have both "P" and "B" or "S" and ":"!') - call stop1() - end if - if (btest(nPBSc,4)) then - if (number) then - if (shifton) then - call errmsg(lineq,iccount-1,ibar, - * 'Started a group shift without stopping prior one!') - call stop1() - else - shifton = .true. - end if - else - if (.not. shifton) then - call errmsg(lineq,iccount-1,ibar, - * 'Ended a group shift without starting one!') - call stop1() - else - shifton = .false. - end if - end if - end if -c -c P off, S off, c off => normal user-defined space. Add to udsp (later fsyst) -c - if (iand(nPBSc,26).eq.0) udsp = udsp+fnum - if (.not.number .and. .not.btest(nPBSc,4)) then - call errmsg(lineq,iccount-1,ibar, - * 'Must have either a number or a colon in "X" symbol!') - call stop1() - end if - return - end -c integer*4 function mytime() -c CHARACTER(10) tq -c CALL DATE_AND_TIME(TIME=tq) -c read(tq,'(2i2,f6.3)')ih,im,ts -c mytime = 1000*(ts+60*(im+60*ih)) -c return -c end - subroutine getbuf(lineq) - parameter (maxblks=4000) - character*(*) lineq - character*65536 bufq - integer*2 lbuf(maxblks) - common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq - lineq = bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) - ipbuf = ipbuf+lbuf(ilbuf) - ilbuf = ilbuf+1 - return - end - subroutine getchar(lineq,iccount,charq) - parameter (nm=24) -c -c Gets the next character out of lineq*128. If pointer iccount=128 on entry, -c then reads in a new line. Resets iccount. Ends program if no more input. -c - common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, - * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, - * rptprev,equalize,rptfq1,rptfq2 - logical lastchar,rptnd1,sluron,fbon,rptprev,ornrpt - common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac - logical mrecord,mplay,endmac,equalize,stickyS - character*1 charq,rptfq1,rptfq2 - character*128 lineq,lnholdq - if (iccount .eq. 128) then - call read10(lineq,lastchar) - if (lastchar) return - if (.not. endmac) then - iccount = 0 - else - endmac = .false. - iccount = icchold - lineq = lnholdq - end if - if (mrecord) then - call mrec1(lineq,iccount,ndxm) - end if - end if - iccount = iccount+1 - charq = lineq(iccount:iccount) - return -999 continue - lastchar = .true. - return - end - subroutine getdyn(ivx,ip,irest,iornq,lineq,iccount) - parameter (nm=24) - common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), - * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), - * idynda2(99),levhssav(nm),listcresc,listdecresc - character*128 txtdynq - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - logical fontslur,upslur,WrotePsslurDefaults - character*1 durq,chax - character*4 dynsymq - character*128 lineq -c -c Get info for dynamic mark. Enter after getting "D", iccount sits on "D" -c Bits in idyndat are as follows -c 00-03 ivx -c 04-11 ip -c 12-15 code for type of mark -c 0 => arbitrary text -c 1-12 => pppp,ppp,pp,p,mp,mf,f,fp,sfz,ff,fff,ffff -c If (.not. fontslur) -c 13 => hairpin start, 14,15 => <,> (ending) -c else -c 13 < start, 14 > start, 15 ending -c end if -c 16 flag for vertical offset -c 17-23 vertical offset + 64 , \internote -c 31 Hairpin start (0), stop (1) -c -c idynda2 -c -c 00 flag for horizontal offset -c 01-09 (horizontal offset)/10 + 25.6 notehead widths -c 10 5th bit for ivx (5/15/10) -c - irest = ibset(irest,26) - ndyn = ndyn+1 - idyn = ivx - idynda2(ndyn) = 0 - if (ivx .ge. 16) call setbits(idynda2(ndyn),1,10,1) - call setbits(idyn,8,4,ip) - if (lineq(iccount+1:iccount+1) .eq. '"') then -c -c text-dynamic -c - ntxtdyn = ntxtdyn+1 - iend = iccount+index(lineq(iccount+2:128),'"')+2 - txtdynq(ntxtdyn) = lineq(iccount+2:iend-2) -c -cc Store ivx, ip in bits 0-11 -c Store ivx, ip in bits 0-12 -c -c ivxiptxt(ntxtdyn) = idyn - ivxiptxt(ntxtdyn) = ivx+32*ip - ipm = index('- +',lineq(iend:iend)) - idno = 0 - else -c -c Word-group or hairpin -c - do 1 iend = iccount+2 , 128 - ipm = index('- +',lineq(iend:iend)) -c -c Exit the loop at first blank, "+", or "-" -c - if (ipm .gt. 0) go to 2 -1 continue -2 continue - read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')') - * dynsymq - idno = (index( - * 'ppppppp pp p mp mf f fp sfz ff fff ffff < > ', - * dynsymq)+3)/4 -c -c Save for later down -c - idno1 = idno - end if -c -c Set flag to check level later if in beam -c - iornq = ibset(iornq,23) - if (idno.ge.14) then -c -c Hairpin here. Check if opposite type from one that's already on -c - if (idno.eq.14.and.btest(listdecresc,ivx) .or. - * idno.eq.15.and.btest(listcresc,ivx)) then - call printl(' ') - call printl('Started one kind of hairpin while other is on') - call stop1() - end if -c -c Start or stop? -c - if (btest(listcresc,ivx) .or. btest(listdecresc,ivx)) then -c -c Cresc/decresc is on, this is an ending. If fontslur, leave idno as is. -c - if (.not.fontslur) idno = 15 - else if (fontslur) then -c -c Start of font slur -c - idno = 13 - else -c -c Start of postscript slur -c - idno = idno-1 - end if - end if -c -c Now that we used list[de]cresc, update -c - if (idno .ge.13) then - if (idno.eq.15 .or. (fontslur.and.idno.eq.14)) then -c -c Something's ending -c - if (btest(listcresc,ivx)) then -c -c It's a cresc! -c - listcresc = ibclr(listcresc,ivx) - else - listdecresc = ibclr(listdecresc,ivx) - end if - else -c -c Something's starting -c - if (idno1 .eq. 14) then -c -c It's a cresc! -c - listcresc = ibset(listcresc,ivx) - else - listdecresc = ibset(listdecresc,ivx) - end if - end if - end if - call setbits(idyn,4,12,idno) - iccount = iend - if (ipm .ne. 2) then -c -c There is a vertical shift -c - idyn = ibset(idyn,16) - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - idno = nint(fnum) - call setbits(idyn,7,17,(ipm-2)*idno+64) - ipm = index('- +',durq) - if (ipm .ne. 2) then -c -c There is a horizontal shift -c -c idynda2(ndyn) = ibset(idyn,23) - idynda2(ndyn) = ibset(idynda2(ndyn),0) - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - idno = nint(10*fnum) - call setbits(idynda2(ndyn),9,1,(ipm-2)*idno+256) - end if -c -c iccount should be on the blank at the end of the entire symbol -c - end if - idyndat(ndyn) = idyn - return - end - subroutine getfig(itoff,charq,lineq,iccount,isfig,itfig, - * itsofar,nodur,figq,ivupfig,nfigs) - logical isfig - character*1 charq - character*10 figq - character*128 lineq -c -c As of 11/26/08, trapped extra figures in getnote, so no need here. -c -c if (ivx .gt. 2) then -cc -cc Read past the figure -cc -c6 call getchar(lineq,iccount,charq) -c if (charq .ne. ' ') go to 6 -c return -c end if - nfigs = nfigs+1 - ivupfig = 0 - itoff = 0 - if (charq .eq. 'x') then -c -c Floating figure. -c - call getchar(lineq,iccount,charq) - read(charq,'(i1)')noff - call getchar(lineq,iccount,charq) - read(charq,'(i1)')loff - itoff = noff*ifnodur(loff,'x') - call getchar(lineq,iccount,charq) - else -c -c Figure on a note -c - isfig = .true. - end if - itfig = itsofar+itoff-nodur - lfig = 1 - figq = charq -5 call getchar(lineq,iccount,charq) -c if (charq .ne. ' ') then - if (index(' +',charq) .eq. 0) then - figq = figq(1:lfig)//charq - lfig = lfig+1 - go to 5 - else if (charq .eq. '+') then -c -c Get vertical offset for figure. Next character after number has to be blank. -c - iccount = iccount+1 - call readnum(lineq,iccount,charq,fnum) - ivupfig = nint(fnum) - end if - return - end - subroutine getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, - * lastlev,iv,nv) - parameter (nm=24) - common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, - * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, - * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, - * graspace(37), - * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), - * naccg(74),voltxtq(6),litq(83) - logical upg,slurg,slashg - character*1 charq,durq - character*20 voltxtq - character*128 lineq,litq - integer*4 islur(nm,200),iornq(nm,0:200),ipl(nm,200),nnl(nm), - * ndlev(nm,2) - common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), - * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans - logical EarlyTransOn,LaterInstTrans -c -c Grace, comes *before* main note: -c UNLESS there's an 'A' or 'W' after the 'G' -c ngrace = # of grace note groups so far in block -c ivg(ngrace), ipg(ngrace) -c nng(ngrace) = # of notes in this group: default = 1 -c ngstrt(ngrace) = starting position in nolevg of levels for this grace -c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' -c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' -c slurg(ngrace) = logical for slur; default F, input 's' -c slashg(ngrace) = T if slash; default is F, input 'x' -c These data MUST precede note name of first note -c nolevg, naccg: lists of levels and accid's, indexed as described above. -c - ngrace = ngrace+1 - ivg(ngrace) = ivx - ipg(ngrace) = nnl(ivx)+1 - if (ngrace .eq. 1) then - ngstrt(ngrace) = 1 - else - ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1) - end if - islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4) - nng(ngrace) = 1 - multg(ngrace) = 1 - upg(ngrace) = .true. - slurg(ngrace) = .false. - slashg(ngrace) = .false. -18 call getchar(lineq,iccount,charq) - if (index('WA',charq) .gt. 0) then -c -c Grace is on note that was already done, so shift flags forward one note. -c This puts flag on actual note with grace; later for W will go ahead one more. -c - ipg(ngrace) = nnl(ivx) - islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4) - islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4) - if (slurg(ngrace)) - * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24) - if (charq .eq. 'A') then -c -c close After, clear way-after bit, to ensure priority of most recent A/W -c - ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29) - else -c -c Way after; later assign to following note, and position like normal grace. -c - ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31) - end if - else if (charq .eq. 'm') then - call getchar(lineq,iccount,charq) - multg(ngrace) = ichar(charq)-48 - else if (index('123456789',charq) .gt. 0) then - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - nng(ngrace) = nint(fnum) - else if (charq .eq. 'l') then - upg(ngrace) = .false. - else if (charq .eq. 's') then - slurg(ngrace) = .true. - if (nnl(ivx) .gt. 0) then -c -c If A- or W-grace, set signal to start slur on main note. -c - if(btest(ipl(ivx,nnl(ivx)),31) .or. - * btest(ipl(ivx,nnl(ivx)),29)) - * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24) - end if - else if (charq .eq. 'x') then - slashg(ngrace) = .true. - else if (charq .eq. 'u') then - else if (charq .eq. 'X') then -c -c Space before main note of grace. Number will come next. -c - iccount = iccount+1 - call readnum(lineq,iccount,durq,graspace(ngrace)) - iccount = iccount-1 - end if - if (index('abcdefg',charq) .eq. 0) go to 18 -c -c At this point, charq is first note name in grace -c - do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1 - naccg(ing) = 0 - ioct = 0 - if (ing .gt. ngstrt(ngrace)) then -55 call getchar(lineq,iccount,charq) - if (charq .eq. ' ') go to 55 - endif - iclastlev = 0 -9 call getchar(lineq,iccount,durq) - if (durq .ne. ' ') then - if (durq.eq.'+') then - lastlev = lastlev+7 - iclastlev = iclastlev+7 - else if (durq.eq.'-') then - lastlev = lastlev-7 - iclastlev = iclastlev-7 - else if (index('fsn',durq) .gt. 0) then - if (naccg(ing) .eq. 0) then - naccg(ing) = index('fsn',durq) - else -c -c Double accidental -c - naccg(ing) = ibset(naccg(ing),2) - end if - else - ioct = ichar(durq)-48 - end if - go to 9 - end if - if (ioct .gt. 0) then - lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) - else - if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then - if (ivx .le. nv) then - kv = 1 - else - kv = 2 - end if - lastlev = ndlev(iv,kv)+iclastlev - end if - lastlev = lastlev-3 - * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) - end if - nolevg(ing) = lastlev -19 continue -c -c Grace could come before first note of block, so reset end level. -c - if (nnl(ivx).eq.0) then - if (ivx .le. nv) then - kv = 1 - else - kv = 2 - end if - ndlev(iv,kv) = lastlev - end if - return - end - subroutine GetiTransInfo(From1,ibarcnt,lineq,iccount, - * ibaroff,nbars,noinst,iv) -cccccccccccccccccccccccc -cc -cc GetiTransInfo.for -cc -cccccccccccccccccccccccc -c -c Called from both g1etnote and getnote, after first 'i' in Ki[...] -c On entry, iccount points to last char retrieved, which is 'i' -c -c From1: locgical, true if called from g1etnote -c ibarcnt: tells whether to set EarlyTransOn to true. -c EarlyTransOn set false in blkdata, true here, back to false in topfile. -c -c 110522/110529 -c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] -c and repeat i[...] for multiple instruments. Store info in g1etnot if ibarcnt=0 -c so can pass to topfile (via comInstTrans), which is called before getnote. -c Otherwise, will store info from getnote. Initialize EarlyTransOn and -c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from g1etnote; -c LaterInstTrans from getnote. Zero both out after use. nInstTrans really -c only needed for instrument-signatures, not transpositions. iTransAmt is -c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for -c each staff. -c -c iTransAmt stored as fn of instrument #, not like iTransKey which is -c fn. of nm, just a counter, where corr. inst num is iInstTrans(nm). This -c simplifies use of iTransAmt for all calls to ifnolev. -c - parameter (nm=24) - logical From1 - common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), - * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans - logical EarlyTransOn,LaterInstTrans,store - character*128 lineq - character*1 durq - durq = 'x' ! Can't initialize in declaration stmt, only works once. - if(.not.EarlyTransOn) EarlyTransOn = From1 .and. ibarcnt.eq.0 - store = (EarlyTransOn.and.ibarcnt.eq.0) .or. - * (ibarcnt.gt.0.and..not.From1) - LaterInstTrans = .not.From1 .and. ibarcnt.gt.0 - if (store) nInstTrans = 0 -1 continue - if (durq .eq. ' ') return - call g1etchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'There must be an instrument number here!') - call stop1() - end if - if (store) nInstTrans = nInstTrans+1 - call readnum(lineq,iccount,durq,fnum) - instn = nint(fnum) - if (instn.gt.noinst) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Instrument number out of range!') - call stop1() - end if - if (store) iInstTrans(nInstTrans) = instn -c -c durq is +/- following inst # (for iTransAmt), iccount is on it. -c - if (index('+-',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '1st character after instrument number must be "+,-"!') - call stop1() - end if - itramt = 44-ichar(durq) ! +1/-1 for itramt - call g1etchar(lineq,iccount,durq) - if (index('0123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'There must be a transposition amount here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - if (store) iTransAmt(instn) = nint(fnum)*itramt -c -c durq is +/- following iTransAmt (for iTransKey), iccount is on it. -c - if (index('+-',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '1st character after transposition amount must be "+,-"!') - call stop1() - end if - ikey = 44-ichar(durq) ! +1/-1 - call g1etchar(lineq,iccount,durq) - if (index('0123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'There must be a key indicator here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - if (store) iTransKey(nInstTrans) = nint(fnum)*ikey -c -c durq is now 1st character after iTransKey, should be either 'i' or ' ' -c - if (durq.ne.'i'.and.durq.ne.' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'There must be blank or "i" here!') - call stop1() - end if - go to 1 - end - subroutine getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, - * mtrdenl,first) -c -c Use this from both pmxa and pmxb to input and check midi data. "first" tells -c whether pmxa or pmxb. If .not.first, then tempo and pause commands cause -c things to be written immediately into the midi storage buffers. -c - parameter (nm=24,mv=24576) - common /comevent/ miditime,lasttime - logical mmacrec,gottempo - common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, - * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), - * mmacrec,gottempo -c -c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing -c nmidsec section starts and stops based on PLAYING macros (not recording). -c - integer*2 mmidi,midinum(26) - logical restpend,relacc,notmain,twoline,ismidi,crdacc - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) - * ,miditran(nm),midtc(0:nm) - character*1 durq - character*2 instq - character*128 lineq - logical first - common /comdiag/ n69(0:nm),n34(0:nm) -c -c Instrument codes -c - data midinum - * / 1, 5, 7, 13,20,25,33,41,42,43,44,57,58,59,61,65,66,67, -c XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbXtuXfrXsoXalXteX -c - * 68,69,71,72,74,75, 8,55 / -c bsXobXbaXclXflXreXctXvo -c -1 call getchar(lineq,iccount,durq) - if (durq .eq. 't') then -c -c Tempo in beats ber minute -c - call getchar(lineq,iccount,durq) - if (index('0123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected an integer here for the pause!') - call stop1() -c else if (mmacrec) then -c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, -c * 'Cannot change MIDI tempo while recording a MidiMacro!') -c call stop1() - end if - call readnum(lineq,iccount,durq,qpm) - iccount = iccount-1 - if (.not.first) then - call midievent('t',nint(qpm),0) - gottempo = .true. - end if - go to 1 - else if (durq .eq. 'p') then -c -c Insert a pause. pausemid = pause in 1/4's -c - call getchar(lineq,iccount,durq) - if (index('0123456789.',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected a number here for the pause!') - call stop1() - end if - call readnum(lineq,iccount,durq,pausemid) - iccount = iccount-1 - if (.not.first) then -c -c Compute a meter for the pause. This is only to keep MidiNotate on track. -c Round pause to nearest 16th. Let denominator always be 16. -c - numb16 = nint(pausemid*4) - call midievent('m',numb16,16) -c -c Put in pausemid beats of rest -c - do 3 icm = 0 , numchan-1 - call addmidi(icm,0,0,0,4.*numb16,.true.,.false.) -3 continue - miditime = miditime+nint(240*pausemid) -c -c Restore meter -c - call midievent('m',mtrdenl*lenbar/64,mtrdenl) - end if - go to 1 - else if (durq .eq. 'i') then -c -c Instrument numbers or letters. Expect nv of them. -c - do 2 ivx = 1 , nv - call getchar(lineq,iccount,durq) - if (ichar(durq) .gt. 96) then -c -c It's a lowercase letter. Get another, find corr. instrument #. -c - instq(1:1) = durq - call getchar(lineq,iccount,durq) - instq = instq(1:1)//durq - iname = index('XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbX'// - * 'tuXfrXsoXalXteXbsXobXbaXclXflXreXctXvo',instq)/3 - if (iname .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Unrecognized 2-letter midi instrument name!') - call stop1() - end if - midinst(ivx) = midinum(iname)-1 - else -c -c Expect a number, followed by ":" if that is followed by another number. -c I.e., if after call to readnum, durq is not ":", it must be either blank -c or next instrument letter. -c - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected a midi instrument number here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - midinst(ivx) = nint(fnum)-1 - if (midinst(ivx).lt.0 .or. midinst(ivx).gt.255) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Midi instrument number must be in range 1-128!') - call stop1() - end if - if (durq .ne. ':') iccount = iccount-1 - end if -2 continue - go to 1 - else if (durq .eq. 'v') then -c -c Get volumes for each instrument. Expect nv of them. -c Follow same pattern as for insttrument numbers above. -c - do 7 ivx = 1 , nv - call getchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected a midi velocity number here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - midivel(ivx) = nint(fnum)-1 - if (midivel(ivx).lt.0 .or. midivel(ivx).gt.127) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Midi velocity must be in range 1-128!') - call stop1() - end if - if (durq .ne. ':') iccount = iccount-1 -7 continue - go to 1 - else if (durq .eq. 'b') then -c -c Get balance for each instrument. Expect nv of them. -c Follow same pattern as for instrument numbers above. -c - do 8 ivx = 1 , nv - call getchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected a balance number here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - midibal(ivx) = nint(fnum)-1 - if (midibal(ivx).lt.0 .or. midibal(ivx).gt.127) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Midi balance must be in range 1-128!') - call stop1() - end if - if (durq .ne. ':') iccount = iccount-1 -8 continue - go to 1 - else if (durq .eq. 'T') then -c -c Get transposition for each instrument. Expect nv of them. -c Follow similar pattern as above, but separator is +|-. -c - do 9 ivx = 1 , nv - call getchar(lineq,iccount,durq) - ipm = index('-+',durq) - if (ipm .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected "+" or "-" for midi transposition here!') - call stop1() - end if - ipm = 2*ipm-3 - call getchar(lineq,iccount,durq) - if (index('0123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected a number here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - miditran(ivx) = ipm*nint(fnum) -c if (mod(miditran(ivx),12).ne. 0) then -c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, -c * 'Midi transposition limited to multiples of 12!') -c call stop1() -c end if - iccount = iccount-1 -9 continue - go to 1 - else if (durq .eq. 'g') then - call getchar(lineq,iccount,durq) - if (index('0123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected an integer here for the midi gap!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - mgap = nint(fnum) - iccount = iccount-1 - go to 1 - else if (durq .eq. 'M') then -c -c MidiMacros -c - call getchar(lineq,iccount,durq) - if (durq .eq. 'R') then -c -c Start recording -c - if (mmacrec) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'You tried to record a MidiMacro while already recording!') - call stop1() - end if - mmacrec = .true. - call getchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected MidiMacro ID number here!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - if (.not.first) then - immac = nint(fnum) - if (immac .gt. 20) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'MidiMacro ID cannot exceed 20!') - call stop1() - end if -c -c Save the start time -c - mmactime(immac) = miditime - do 4 icm = 0 , numchan - if (icm .lt. numchan) then - if (restpend(icm)) then -c -c Adjust if there's a rest at end of prior section. Insert dummy turnoff. -c (This causes two turn-offs in a row, which testmidi sees as an error). -c -c Before: section1 ------rest------- section2(to be recorded) -c After: section1 rest1 now rest2 section2(recorded) -c - call addmidi(icm,30,0,0,trest(icm),.false.,.true.) - trest(icm) = 0 - restpend(icm) = .false. - end if - else - if (miditime .gt. lasttime) then -c -c Insert a dummy turnoff in conductor track -c - call addmidi(icm,30,0,0,(miditime-lasttime)/15., - * .false.,.true.) - lasttime = miditime - end if - end if - mmacstrt(icm,immac) = imidi(icm)+1 -4 continue - end if - go to 1 - else if (index('123456789P',durq) .eq. 0) then -c -c End recording; close the open macro. Get immac from common. -c - if (.not.mmacrec) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'You tried to end a MidiMacro before starting one!') - call stop1() - end if - mmacrec = .false. - iccount = iccount-1 - if (.not.first) then -c -c Save the macro duration -c - mmactime(immac) = miditime-mmactime(immac) - do 5 icm = 0 , numchan - if (icm .lt. numchan) then - if (restpend(icm)) then - call addmidi(icm,30,0,0,trest(icm),.false.,.true.) - trest(icm) = 0 - restpend(icm) = .false. - end if - else - if (miditime .gt. lasttime) then -c -c Insert a dummy turnoff in conductor track if needed. -c - call addmidi(icm,30,0,0,(miditime-lasttime)/15., - * .false.,.true.) - lasttime = miditime - end if - end if - mmacend(icm,immac) = imidi(icm) -5 continue - end if - if (durq .ne. ' ')go to 1 - else if (durq .eq. 'P') then -c -c Play Back a Macro -c - call getchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Expected MidiMacro ID number here!') - call stop1() - end if - if (mmacrec) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'You tried to play a MidiMacro before ending recording!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - if (.not.first) then - immac = nint(fnum) - if (mmactime(immac) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Cannot play a MIDI macro before recording it!') - call stop1() - end if - do 6 icm = 0 , numchan - if (icm .lt. numchan) then - if (restpend(icm)) then - call addmidi(icm,30,0,0,trest(icm),.false.,.true.) - trest(icm) = 0. - restpend(icm) = .false. - end if - else - if (miditime .gt. lasttime) then -c -c Insert a dummy turnoff in conductor track -c - call addmidi(icm,30,0,0,(miditime-lasttime)/15., - * .false.,.true.) - end if - end if - msecend(icm,nmidsec) = imidi(icm) - msecstrt(icm,nmidsec+1) = mmacstrt(icm,immac) - msecend(icm,nmidsec+1) = mmacend(icm,immac) - msecstrt(icm,nmidsec+2) = imidi(icm)+1 -6 continue - nmidsec = nmidsec+2 -c -c Update running time -c - miditime = miditime+mmactime(immac) - lasttime = miditime - end if - go to 1 - else - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in MidiMacro sub-command!') - call stop1() - end if - else if (durq .eq. 'd') then - debugmidi = .true. - go to 1 - else if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character in MIDI input data!') - call stop1() - end if - if (.not.gottempo .and. .not.first) then -c -c If no tempo is set on first call on the pmxb pass, then set it -c - call midievent('t',96,0) - gottempo = .true. - end if - return - end - subroutine getnote(loop) - parameter (nm=24,mv=24576) - common /comlast/ islast,usevshrink - logical islast,usevshrink - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - character*10 figq - character*1 ulq,sepsymq,sq,rptfq1,rptfq2,clefq,chax - logical beamon,firstgulp,figbass,figchk,isfig - character*60 cheadq - character*120 instrq,titleq,compoq - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc,autofbon - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 - common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, - * inhead - common /cominbot/ inbothd - common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), - * fullsize(nm),ivxfig2 - common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd, - * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage, - * OptLineBreakTies,HeaderSpecial - common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, - * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, - * rptprev,equalize,rptfq1,rptfq2 - common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt - common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, - * tautofb,autofbon,t1autofb - common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, - * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, - * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, - * graspace(37), - * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), - * naccg(74),voltxtq(6),litq(83) - logical upg,slurg,slashg,fbon,ornrpt,shifton,setis,notcrd,isbjmp, - * was2,nobar1,quoted,isbj2,stickyS, - * OptLineBreakTies,HeaderSpecial - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - character*128 litq - common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), - * ndotmv(nm),updot(nm,20),rtdot(nm,20) - common /combc/ bcspec - common /comas3/ ask(2500),iask,topmods -c -c nvmx is either 1 or 2. ivmx(iv,1)=iv, ; ivmx(iv,2)>nv if defined -c ivx is current ivmx, and is the index for all notes, acc's etc. -c - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, - * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, - * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, - * rtshfac - common /comtrans/ cheadq - common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, - * isig,lastisig,fracindent,widthpt,height,idsig, - * lnam(nm),inameq(nm) - common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac - common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) - common /comask/ bar1syst,fixednew,scaldold, - * wheadpt,fbar,poenom - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), - * xinsnow,lowdot - common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) - common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), - * ic1mac(20),ilmac,iplmac - common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), - * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), - * idynda2(99),levhssav(nm),listcresc,listdecresc - common /comclefq/ clefq(nm) - common /comtol/ tol - common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), - * ArpShift(20) - character*128 txtdynq - logical mrecord,mplay,endmac,lowdot,rename,bar1syst,upslur, - * fontslur,WrotePsslurDefaults - character*128 lineq,lnholdq - character*80 headrq, lowerq - character*79 inameq - character*59 hdlndq - character*20 voltxtq - character*1 charq,dotq,durq,ulfbq,dumq - logical loop,lastchar,lower,rptnd1,rptprev,bcspec,moved, - * topmods,headlog,btest,sluron,cdot,equalize - character*24 tempq - logical novshrinktop,cstuplet - common /comnvst/ novshrinktop,cstuplet - logical kbdrests - common /comkbdrests/ levbotr(8),levtopr(8),kbdrests - common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), - * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans - logical EarlyTransOn,LaterInstTrans - - common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idumm1,isig1, - * mbrestsav,kchmid(18),logdumm1,logdumm2,barend,noinst,logdumm3 - logical barend,iskchb,kchmid,logdumm1,logdumm2,logdumm3 - common /combibarcnt/ ibarcnt - cdot = .false. -1 call getchar(lineq,iccount,charq) - if (lastchar) return - if (charq .eq. ' ') go to 1 - if (charq .eq. '%') then -c -c Check for a bar number format: -c - if (iccount.eq.1 .and. lineq(2:2).eq.' ' .and. - * index('bB1234567890',lineq(3:3)).gt.0) then - if (islast) write(11,'(a)')lineq(1:lenstr(lineq,128)) - end if - iccount = 128 - go to 1 - end if -c -c Closing repeat iff charq='/' and the prev. char was 'R' with 'd' or 'r' -c - if (rptprev) then - rptnd1 = charq .eq. '/' - rptprev = .false. - end if -c -c Repeat at end of a piece -c - if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. - * charq.eq.'r') then - if (cdot) go to 28 -c -c This is a note/rest. -c - idotform = 0 - numnum = 0 -c -c If start of line of music, set pitch from previous -c - if (ivx .le. nv) then - kv = 1 - else - kv = 2 - end if - if (nnl(ivx).eq.0) lastlev = ndlev(iv,kv) -c -c notcrd is used to tell if orn. goes on main note or chord note -c -c notcrd = .true. !Move dow. Was not observed if dotted shortcut. -c -c Increase note count, then loop 'til blank. Label 28 is for dotted shortcuts. -c -28 continue -c -c Moved this from just above, 2 Feb 02 -c - notcrd = .true. - nnl(ivx) = nnl(ivx)+1 - if (ornrpt) then -c -c Replicate ornament bits, also bit 23 for beam handling if chord. -c - iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),iornq(ivx,0)) - if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then -c -c This is a trill (bit 7 or 15) so must dup the parameters -c - ntrill = ntrill + 1 - ivtrill(ntrill) = ivx - iptrill(ntrill) = nnl(ivx) - xnsktr(ntrill) = xnsktr(ntrill-1) - end if - end if - if (stickyS) then -c -c Grab stemlength shortening parameters from prior note -c - mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27) - call setbits (mult(ivx,nnl(ivx)),3,28, - * igetbits(mult(ivx,nnl(ivx)-1),3,28)) - end if - if (autofbon .and. tautofb.gt.tol .and. .not.fbon) then -c -c Doing auto forced beams, and period has been set, so check if this note -c starts a period. -c -c if (mod(1.*itsofar(ivx),tautofb) .lt. tol) then - if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then -c -c Start a forced beam here -c - nfb(ivx) = nfb(ivx)+1 - fbon = .true. - ulfbq(ivx,nfb(ivx)) = 'x' - t1fb(ivx,nfb(ivx)) = itsofar(ivx) - end if - end if - if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30) - dotq = 'x' - if (charq.eq.'r') - * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0) - if (btest(irest(ivx,nnl(ivx)),0)) then -c -c Rest stuff. First check if previous note was full-bar-pause -c - if (lineq(iccount+1:iccount+1) .eq.' ' - * .and. nnl(ivx).gt.1) then - if (btest(islur(ivx,nnl(ivx)-1),19)) - * islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19) - end if -c -c Set default rest level at 0 unless 2 voices/staff in which case it's -4 or 2 -c for voice a or b. Set a-types at 0 as encountered and adjust later -c after '//'. (Override heights will be set to 100+offset) -c - if (ivx .le. nv) then - nolev(ivx,nnl(ivx)) = 0 - else - nolev(ivx,nnl(ivx)) = 2 - end if - end if -2 call getchar(lineq,iccount,durq) - ic = ichar(durq) - if (ic.le.57 .and. ic.ge.48) then -c -c Digit -c - if (numnum .eq. 0) then - nnodur = ic-48 - numnum = 1 - go to 2 - else if (numnum .eq. 1) then - ioct = ic-48 - numnum = 2 - go to 2 - else - print*,'>2 digits in note sym., ivx,nn:',ivx,nnl(ivx) - call stop1() - end if - else if (durq .eq. 'd') then - dotq = durq - if (lineq(iccount+1:iccount+1) .eq. 'd') then -c -c Double dot. -c - iccount = iccount+1 - islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),3) - end if - if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then -c -c move a dot, unless next char is not part of a number -c - if (index('0123456789.',lineq(iccount+2:iccount+2)) .eq. 0) - * go to 2 - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),19) - call getchar(lineq,iccount,durq) - ndotmv(ivx) = ndotmv(ivx)+1 - iccount=iccount+1 - call readnum(lineq,iccount,dumq,updot(ivx,ndotmv(ivx))) - if (durq .eq. '-') - * updot(ivx,ndotmv(ivx)) = -updot(ivx,ndotmv(ivx)) - if (index('+-',dumq) .gt. 0) then -c -c Vertical shift also -c - iccount=iccount+1 - call readnum(lineq,iccount,durq,rtdot(ivx,ndotmv(ivx))) - if (dumq .eq. '-') - * rtdot(ivx,ndotmv(ivx)) = -rtdot(ivx,ndotmv(ivx)) - else - rtdot(ivx,ndotmv(ivx)) = 0. - end if - iccount = iccount-1 - end if - go to 2 - else if (durq .eq. 'p') then -c -c Full-bar rest as pause -c - islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19) - go to 2 - else if (durq .eq. 'b') then -c -c Blank rest -c - islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29) - go to 2 - else if (index('fsn',durq) .gt. 0) then -c -c Accidental -c - if (nacc(ivx,nnl(ivx)) .eq. 0) then -c -c No accidental has been set yet -c - nacc(ivx,nnl(ivx)) = index('fsn',durq) - else -c -c Repeated accid, so must be double -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2) - end if - go to 2 - else if (durq .eq. 'i') then -c -c Set flag for MIDI-only accidental. -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17) - go to 2 - else if (durq .eq. 'c') then -c -c Set flags for cautionary accidental -c - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31) - iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) - go to 2 - else if (index('+-<>',durq) .gt. 0) then - ipm = index('- +',durq)-2 - if (.not.btest(irest(ivx,nnl(ivx)),0)) then -c -c A note, not a rest. -c - call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved) - if (moved) go to 2 -c -c Octave jump with a note -c - if (numnum .lt. 2) then - lastlev = lastlev+ipm*7 - else - ioct = ioct+ipm*1 - end if - go to 2 - else -c -c Override default height of a rest -c - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - if (lineq(iccount-1:iccount-1) .eq. '.') then -c -c Kluge in case there is a shortcut ".". It will have been sucked up by -c readnum. (Same doesn't hold for ",") -c - iccount = iccount-2 - go to 2 - end if - nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum) -c -c There may be more characters for this rest -c - iccount = iccount-1 - go to 2 - end if - else if (durq .eq. 'x') then -c -c Xtuplet. Count number of doubled notes (for unequal xtups) -c - if (btest(nacc(ivx,nnl(ivx)),18)) then - ndoub = 1 - else - ndoub = 0 - end if -c -c Will set all durations to 0 except last one. Set flag on this note. -c - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),28) -c -c Next input will be digit -c - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - ntup = nint(fnum) - if (index('DF',durq) .gt. 0) then -c -c Double xtup note to make an un= xtup. Here xtup number already set but may also -c have this command before. -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) - if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = - * ibset(nacc(ivx,nnl(ivx)),19) - ndoub = 1 - call getchar(lineq,iccount,durq) - else if (durq .eq. 'd') then - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) - call getchar(lineq,iccount,durq) - end if -c -c Only other possibilities here are ' ' or 'n' -c - if (durq .eq. 'n') then -c -c Alter xtup number -c - if (lineq(iccount+1:iccount+1) .eq. ' ') then -c -c If the only modifier is 'n', cancel the number -c - islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),31) - else - numshft = 0 -30 call getchar(lineq,iccount,durq) - if (durq .eq. 'f') then -c -c Flip up-down-ness -c - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),14) - go to 30 - else if (index('+-',durq) .gt. 0) then -c -c Vertical or horiz shift -c - numshft = numshft+1 - iofforn = 1 - if (durq .eq. '-') iofforn = -1 - iccount = iccount+1 - call readnum(lineq,iccount,durq,xofforn) - iccount = iccount-1 - if (numshft .eq. 1) then -c -c Vertical shift -c - iofforn = iofforn*nint(xofforn) + 16 -c -c Turn on bit 1; set bits 2-6 to iofforn -c - irest(ivx,nnl(ivx)) = - * ior(irest(ivx,nnl(ivx)),2+4*iofforn) - else -c -c Horizontal shift -c - iofforn = iofforn*nint(xofforn*10)+16 - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),7) - call setbits(irest(ivx,nnl(ivx)),5,9,iofforn) - end if - go to 30 - else if (durq .eq. 's') then -c -c Slope adjustment for bracket -c - mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),4) - call getchar(lineq,iccount,durq) - iofforn = index('- +',durq)-2 - iccount = iccount+1 - call readnum(lineq,iccount,durq,xofforn) - iccount = iccount-1 - iofforn = nint(iofforn*xofforn+16) - call setbits(mult(ivx,nnl(ivx)),5,5,iofforn) - else if (index('123456789',durq) .gt. 0) then -c -c Replacement printed number -c - call readnum(lineq,iccount,durq,xofforn) - call setbits(nacc(ivx,nnl(ivx)),5,22,nint(xofforn)) - iccount = iccount-1 - go to 30 - end if - end if - end if -c -c Set note level of 1st note of xtup, provided not a rest -c - if (.not.btest(irest(ivx,nnl(ivx)),0)) then - if (numnum .eq. 2) then - lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) - nolev(ivx,nnl(ivx)) = lastlev - else - lastlev = lastlev-3 - * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) - nolev(ivx,nnl(ivx)) = lastlev - end if - end if - do 40 npreslur = npreslur , 1 , -1 -c -c Set note level for preslur on starting note of xtuplet -c - call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev) -40 continue - numnum = 0 - nodur(ivx,nnl(ivx)) = 0 - do 6 itup = 2 , ntup - if (ornrpt) then - iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)), - * iand(iornq(ivx,nnl(ivx)-1),10026991)) - if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then -c -c This is a trill (bit 7 or 15) so must dup the parameters -c - ntrill = ntrill + 1 - ivtrill(ntrill) = ivx - iptrill(ntrill) = nnl(ivx) - xnsktr(ntrill) = xnsktr(ntrill-1) - end if - end if - nnl(ivx) = nnl(ivx)+1 - if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30) -7 call getchar(lineq,iccount,charq) - if (charq .eq. ' ') then - go to 7 - else if (charq .eq. '%') then - iccount = 128 - go to 7 - else if (charq .eq. 'o') then -c -c Ornament in xtuplet. "o" symbol must come AFTER the affected note -c - if (notcrd) then - nole = nolev(ivx,nnl(ivx)-1) - else - nole = iand(127,ishft(icrdat(ncrd),-12)) - end if - call getorn(lineq,iccount,iornq(ivx,nnl(ivx)-1), - * iornq(ivx,0),ornrpt,noffseg, - * nnl(ivx)-1,ivx,.false.,notcrd,nole) - go to 7 - else if (index('st(){}',charq) .gt. 0) then - nnlivx = nnl(ivx)-1 - if (charq.eq.'(' .or. charq.eq.'{') then -c -c Detected preslur in xtuplet loop, non-chord note -c - nnlivx = nnlivx+1 - npreslur = npreslur+1 - end if - islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0) - if (charq.eq.'t') islur(ivx,nnlivx) = - * ibset(islur(ivx,nnlivx),1) - if (ivx .le. nv) then - kv = 1 - else - kv = 2 - end if - if (fontslur) then - call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2, - * isdat3,nsdat,notcrd,nolev(ivx,nnlivx),charq) - else - call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2, - * isdat3,isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq) - end if - go to 7 - else if (charq .eq. 'G') then -c -c Kluge to get grace in xtup at right location -c - nnl(ivx) = nnl(ivx)-1 - call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, - * lastlev,iv,nv) - nnl(ivx) = nnl(ivx)+1 - go to 7 - else if (charq .eq. sq) then - call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount) - go to 7 - else if (index('0123456789#-nx_',charq) .gt. 0) then -c -c Figure. Must come AFTER the first note of xtup -c - ivf = 1 - if (ivx .gt. 1) then - if (ivxfig2 .eq. 0) then - ivxfig2 = ivx - else if (ivx .ne. ivxfig2) then - print* - print*,'Figures not allowed in >1 voice above first' - stop - end if - ivf = 2 - end if - nfig1 = nfigs(ivf)+1 - call getfig(itoff(ivf,nfig1),charq,lineq,iccount, - * isfig(ivf,nnl(ivx)-1),itfig(ivf,nfig1),itsofar(ivx), - * 0,figq(ivf,nfig1),ivupfig(ivf,nfig1),nfigs(ivf)) - go to 7 - else if (charq .eq. 'X') then - call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx)-1)), - * shifton,wheadpt,iornq(ivx,nnl(ivx)),ivx, - * irest(ivx,nnl(ivx)),itsofar(ivx),ntup,itup,nnodur, - * dotq,ndoub) - go to 7 - else if (charq .eq. 'z') then -c -c Chord note in xtup. Goes with *prior* note. -c - notcrd = .false. - ncrd = ncrd+1 - ipl(ivx,nnl(ivx)-1) = ibset(ipl(ivx,nnl(ivx)-1),10) - numnum = 0 -c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) - icrdat(ncrd) = nnl(ivx)-1 - call setbits(icrdat(ncrd),4,8,mod(ivx,16)) - if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28) - icrdorn(ncrd) = 0 -c -c Get note name -c - call getchar(lineq,iccount,charq) -c -c Get optional inputs -c -34 call getchar(lineq,iccount,durq) -c -c When chord note is done, will get ' ', making ndx=0, so go past this block -c - ndx = index('fsn+-<>12345678reic',durq) - if (ndx .gt. 0) then - if (ndx .le. 3) then - if (.not.btest(icrdat(ncrd),19)) then - icrdat(ncrd) = ibset(icrdat(ncrd),19) - icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20)) - else - icrdat(ncrd) = ibset(icrdat(ncrd),22) - end if - else if (ndx .eq. 19) then -c -c Set flags for cautionary accidental -c - icrdat(ncrd) = ibset(icrdat(ncrd),31) - iornq(ivx,nnl(ivx)-1) = - * ibset(iornq(ivx,nnl(ivx)-1),31) - else if (ndx .le. 7) then -c -c +/-/</> Check whether octave or accidental shift -c - nactmp = 0 - call chkpm4ac(lineq,iccount,nactmp,moved) - if (moved) then -c -c Transfer accidental shift values -c - call setbits(icrdot(ncrd),6,14, - * igetbits(nactmp,6,4)) - call setbits(icrdot(ncrd),7,20, - * igetbits(nactmp,7,10)) - else - if (durq .eq. '+') then - lastlev = lastlev+7 - else if (durq .eq. '-') then - lastlev = lastlev-7 - end if - end if - else if (durq .eq. 'e') then - icrdat(ncrd) = ibset(icrdat(ncrd),23) - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) - else if (durq .eq. 'r') then - icrdat(ncrd) = ibset(icrdat(ncrd),24) - irest(ivx,nnl(ivx)-1) = - * ibset(irest(ivx,nnl(ivx)-1),20) - else if (durq .eq. 'i') then -c -c Midi-only accidental -c - icrdat(ncrd) = ibset(icrdat(ncrd),27) - else -c -c must be a number, save it in ioct -c - numnum = 1 - ioct = ndx-7 - end if - go to 34 - end if - if (numnum .eq. 1) then - lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) - else - lastlev = lastlev-3 - * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) - end if - icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12)) - do 41 npreslur = npreslur , 1 , -1 -c -c Set note level for preslur on chord note in xtup -c - call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) -c -c Following lines copied from loop for non-xtup, chord note, preslur -c Initially I assigned the slur(s) to next note, so fix. -c - islur(ivx,nnl(ivx)) = ibclr(islur(ivx,nnl(ivx)),0) - islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),0) - isdat2(nsdat-npreslur+1) = - * ibset(isdat2(nsdat-npreslur+1),0) - call setbits(isdat1(nsdat-npreslur+1),8,3, - * igetbits(isdat1(nsdat-npreslur+1),8,3)-1) -41 continue - go to 7 - else if (charq .eq. '?') then -c -c Arpeggio -c - if (btest(ipl(ivx,nnl(ivx)-1),10)) then -c -c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note -c of chord, will not set icrdat(25), but iornq(27) -c - icrdat(ncrd) = ibset(icrdat(ncrd),25) - else - iornq(ivx,nnl(ivx)-1) = ibset(iornq(ivx,nnl(ivx)-1),27) - end if -c -c Check for shift -c - call getchar(lineq,iccount,durq) - if (durq .eq. ' ') then - iccount = iccount-1 - else -c -c durq must be "-" -c - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 -c -c record the shift -c - NumArpShift = NumArpShift+1 - IvArpShift(NumArpShift) = ivx - IpArpShift(NumArpShift) = nnl(ivx)-1 - ArpShift(NumArpShift) = fnum - end if - go to 7 - else if (charq .eq. 'D') then - call getdyn(ivx,nnl(ivx)-1,irest(ivx,nnl(ivx)-1), - * iornq(ivx,nnl(ivx)-1),lineq,iccount) - go to 7 -c+++ - else if (charq .eq. ']') then -c -c Multiplicity up-down, must have '][ ' -c - islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),20) - iccount = iccount+2 - go to 7 -cc+++ - end if -c -c End of loop for xtup options. If here, charq must be a (non-crd) note name. -c or rest -c - if (charq .eq. 'r') then -c -c Rest in xtup -c - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0) - if (index('+-b',lineq(iccount+1:iccount+1)) .gt. 0) then - call getchar(lineq,iccount,durq) - if (durq .eq. 'b') then -c -c Blank rest in middle of xtup -c - islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29) - else -c -c Override height of embedded xtup rest -c - ipm = index('- +',durq)-2 - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum) - iccount = iccount-1 - end if - else if (ivx .le. nv) then - nolev(ivx,nnl(ivx)) = 0 - else - nolev(ivx,nnl(ivx)) = 2 - end if - end if - notcrd = .true. -8 call getchar(lineq,iccount,durq) - if (durq .ne. ' ') then - if (index('+-<>',durq) .gt. 0) then -c -c Accidental horizontal shift -c - call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved) - if (.not.moved) then - if (durq.eq.'+') then - lastlev = lastlev+7 - else if (durq.eq.'-') then - lastlev = lastlev-7 - end if - end if - else if (index('fsn',durq) .gt. 0) then - if (nacc(ivx,nnl(ivx)) .eq. 0) then -c -c No accid set yet -c - nacc(ivx,nnl(ivx)) = index('fsn',durq) - else -c -c Symbol must be repeated, so it's a double -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2) - end if - else if (durq .eq. 'i') then -c -c Set flag for midi-only accidental -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17) - - else if (durq .eq. 'c') then -c -c Set flags for cautionary accidental -c - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31) - iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) - else if (index('ul',durq) .gt. 0) then -c -c Force stem direction for non-beamed xtup note -c - islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30) - if (durq .eq. 'u') islur(ivx,nnl(ivx)) = - * ibset(islur(ivx,nnl(ivx)),17) - else if (durq .eq. 'e') then -c -c Left-shift main xtup note -c - ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8) - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) - else if (durq .eq. 'r') then -c -c Right-shift main xtup note -c - ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9) - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) - else if (index('DF',durq) .gt. 0) then -c -c Double an xtup note to make an unequal xtup -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) - if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = - * ibset(nacc(ivx,nnl(ivx)),19) - ndoub = ndoub+1 - else if (durq .eq. 'd') then -c -c Dotted xtup note -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) - else -c -c Must be an octave number -c - lastlev = ifnolev(charq,ichar(durq)-48 - * ,iTransAmt(instno(iv))) - end if - go to 8 - end if - if (itup .lt. ntup) then -c -c Last note is handled *after* flowing out of the xtup if block, but still -c within block for a note-rest. Set note level now (rest already done). -c Could have problem here if rests & doubled notes are combined in xtup, -c since might exit the loop at the wrong place. Worry about it later. -c - if (.not.btest(irest(ivx,nnl(ivx)),0)) then - lastlev = lastlev-3+mod(ifnolev(charq,10, - * iTransAmt(instno(iv)))-lastlev+3,7) - nolev(ivx,nnl(ivx)) = lastlev - end if - nodur(ivx,nnl(ivx)) = 0 - do 42 npreslur = npreslur , 1 , -1 -c -c Set note level for preslur on internal xtup note -c - call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) -42 continue - end if - if (itup .eq. ntup-ndoub) go to 12 -6 continue -12 continue - if (ornrpt) then - iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)), - * iand(iornq(ivx,nnl(ivx)-1),10026991)) - if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then -c -c This is a trill (bit 7 or 15) so must dup the parameters -c - ntrill = ntrill + 1 - ivtrill(ntrill) = ivx - iptrill(ntrill) = nnl(ivx) - xnsktr(ntrill) = xnsktr(ntrill-1) - end if - end if -c -c End of if-block for xtuplet input -c - else if (durq .eq. 'm') then -c -c Multi-bar rest: next 1 or two digits are # of bars. -c For some purposes, pretend its one bar only -c - nodur(ivx,nnl(ivx)) = lenbar - ibarmbr = nbars+1 - mbrest = 0 - xb4mbr = 0. -20 call getchar(lineq,iccount,durq) - if (ichar(durq).ge.48.and.ichar(durq).le.57) then - mbrest = 10*mbrest+ichar(durq)-48 - go to 20 - end if - else if (index('ul',durq) .gt. 0) then -c -c Set stem flipper -c - islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30) - if (durq .eq. 'u') islur(ivx,nnl(ivx)) = - * ibset(islur(ivx,nnl(ivx)),17) - go to 2 - else if (durq .eq. 'a') then -c -c "Alone", i.e., prohibit beam -c - islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),18) - go to 2 - else if (durq .eq. 'r') then -c -c Right offset by one notehead -c - ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9) - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) - go to 2 - else if (durq .eq. 'e') then -c -c Left offset by one notehead -c - ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8) - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) - go to 2 - else if (durq .eq. 'S') then -c -c Stemlength change. Get -dstemlen in \internotes. Allowable values are .5 to 4 -c Set mult(27). Map value to 0 to 7, store in mult(28-30). Later convert to -c interbeams = internotes*2/3. -c - mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27) - call getchar(lineq,iccount,durq) - if (durq .eq. ':') then -c -c End stickyS. Grab data now from prior note, since we have to shut off stickyS. -c - call setbits (mult(ivx,nnl(ivx)),3,28, - * igetbits(mult(ivx,nnl(ivx)-1),3,28)) - stickyS = .false. - go to 2 - end if -c -c If durq .ne. ':' then iccount is now on the start of the number -c - call readnum(lineq,iccount,durq,dum) - call setbits (mult(ivx,nnl(ivx)),3,28,nint((dum-.5)*2)) - if (durq .eq. ':') then - stickyS = .true. - else - iccount = iccount-1 - end if - go to 2 - else if (durq .eq. ',') then -c -c 2:1 pattern -c - idotform = 3 -c -c Now flow to duration setting, as if durq=' ' -c - else if (durq .eq. '.') then -c -c Dotted pattern. Close out note. Mult time by 3/4. -c Set time for next note to 1/4. Start the note. -c - idotform = 1 - else if (durq .eq. 'o') then -c -c Suppress rest centering -c - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),25) - go to 2 - else if (durq .eq.'L') then -c -c With keyboard rest option, look left -c - iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),30) - go to 2 - else if (index('DF',durq) .gt. 0) then -c -c Double note for xtup. Must check here in case "D" came before "x" or on -c last note of xtup. Need to flag it in pmxa since affects horiz. spacing. -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) - if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = - * ibset(nacc(ivx,nnl(ivx)),19) - go to 2 - else if (durq .eq. 'A') then -c -c Accidental option -c - call getchar(lineq,iccount,durq) -c - if (durq .eq. 'o') then -c -c Ordered accidentals in a chord. Mark the main note. -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),28) - else -c -c Only other possibility is +-<> . Set tag, reduce iccount and loop to get #'s -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),29) - iccount = iccount-1 - end if - go to 2 - else if (durq .ne. ' ') then - print*,'Illegal character in note: ',durq,', ivx,nn:', - * ivx,nnl(ivx) - call stop1() - end if -c -c Done with note/rest options. Set level and duration. -c - if (.not.btest(irest(ivx,nnl(ivx)),0)) then - if (numnum .eq. 2) then - lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) - nolev(ivx,nnl(ivx)) = lastlev - else - lastlev = lastlev-3 - * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) - nolev(ivx,nnl(ivx)) = lastlev - end if - do 43 npreslur = npreslur , 1 , -1 -c -c Set level for preslur on normal note, non-chord -c - call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev) -43 continue - end if - if (idotform .gt. 0) then - if (idotform .eq. 1) then - nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)*3/2 - else if (idotform .eq. 2) then - nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3 - else if (idotform .eq. 3) then - nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq) - else if (idotform .eq. 4) then - nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2 - end if - else if (btest(islur(ivx,nnl(ivx)),19)) then -c -c Set duration of full-bar rest as pause -c - nodur(ivx,nnl(ivx)) = lenbar -c -c Use a one-line function to set nnodur. It gives inverse of ifnodur. -c - nnodur = index('62514x0x37', - * chax(48+int(log(.1+lenbar)/.69315)))-1 - else if (ibarmbr.ne.nbars+1) then - nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq) - if (btest(islur(ivx,nnl(ivx)),3)) - * nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6 - end if - if (shifton .and. .not.btest(irest(ivx,nnl(ivx)),16)) then -c -c Shift is on, and this is not first shifted note. Check for duration change -c - if (nodur(ivx,nnl(ivx)) .ne. nodur(ivx,nnl(ivx)-1)) then -c -c Must stop and restart the offset. -c - irest(ivx,nnl(ivx)-1) = ibset(irest(ivx,nnl(ivx)-1),17) - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),16) - nudoff(ivx) = nudoff(ivx)+1 - udoff(ivx,nudoff(ivx)) = udoff(ivx,nudoff(ivx)-1) - end if - end if - itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) - if (autofbon .and. tautofb.gt.tol .and. fbon) then -c -c Check to see if need to terminate auto forced beam -c - if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then -c -c Terminate autofb -c - t2fb(ivx,nfb(ivx)) = itsofar(ivx) - fbon = .false. - end if - end if - if (mod(itsofar(ivx)-lenb0,lenbar) .eq. 0) then -c -c Finished a bar -c - nbars = nbars+1 - nib(ivx,nbars) = nnl(ivx) - if (firstgulp.and.lenb0.ne.0.and.nbars.eq.1) then -c -c Just finished the pickup bar for this voice. -c - lenbar = lenb1 - end if - end if - if (idotform .eq. 1) then - call getchar(lineq,iccount,charq) - idotform = 2 - numnum = 1 - go to 28 - else if (idotform .eq. 3) then - call getchar(lineq,iccount,charq) - idotform = 4 - numnum = 1 - go to 28 - end if -c -c End of sub block for note-rest -c - else if (charq .eq. 'z') then -c -c Chord note. Must have note name, may have octave#,+,-,s,f,n,d -c Actually the 'd' is not used, since time value comes from -c basic note. Unless dot is to be shifted! -c Doesn't increase # of notes, so must handle separately -c ncrd: index of crd -c Set bit 10 of ipl on main note as flag -c Bits in icrdat: -c 0-7 ip within voice -c 8-11 ivx -c 12-18 note level -c 19 accidental? -c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) -c 23 shift left -c 24 shift right -c 25 arpeggio start or stop -c 26 flag for moved dot (here, not icrdot, since this is always reset!) -c 27 Midi-only accidental -c 29 Tag for accidental shift...means add to autoshifts. -c 31 Cautionary accidental -c -c Bits in icrdot: -c 0-6 10*abs(vertical dot shift in \internote) + 64 -c 7-13 10*abs(horizontal dot shift in \internote) + 64 -c 14-19 vert accidental shift-32 -c 20-26 20*(horiz accidental shift+3.2) -c 27-29 top-down level rank of chord note w/accid. Set in crdaccs. -c -c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. -c - ncrd = ncrd+1 - ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),10) - numnum = 0 -c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) - icrdat(ncrd) = nnl(ivx) - call setbits(icrdat(ncrd),4,8,mod(ivx,16)) - if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28) - icrdot(ncrd) = 0 - icrdorn(ncrd) = 0 -c -c Get note name -c - call getchar(lineq,iccount,charq) -c -c Get optional inputs -c -25 call getchar(lineq,iccount,durq) -c ndx = index('fsn+-<>12345678rediA',durq) - ndx = index('fsn+-<>12345678rediAc',durq) - if (ndx .eq. 20) then -c -c Expect +|-|<|> , set tag, loop -c - icrdat(ncrd) = ibset(icrdat(ncrd),29) - go to 25 - else if (ndx .gt. 0) then - if (ndx .le. 3) then - if (.not.btest(icrdat(ncrd),19)) then - icrdat(ncrd) = ibset(icrdat(ncrd),19) - icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20)) - else - icrdat(ncrd) = ibset(icrdat(ncrd),22) - end if - else if (ndx .eq. 21) then -c -c Set flags for cautionary accidental -c - icrdat(ncrd) = ibset(icrdat(ncrd),31) - iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) - else if (ndx .le. 7) then -c -c +/-/</> Check whether octave or accidental shift -c - nactmp = 0 - call chkpm4ac(lineq,iccount,nactmp,moved) - if (moved) then -c -c Transfer accidental shift values -c - call setbits(icrdot(ncrd),6,14,igetbits(nactmp,6,4)) - call setbits(icrdot(ncrd),7,20,igetbits(nactmp,7,10)) - else - if (durq .eq. '+') then - lastlev = lastlev+7 - else if (durq .eq. '-') then - lastlev = lastlev-7 - end if - end if - else if (durq .eq. 'e') then - icrdat(ncrd) = ibset(icrdat(ncrd),23) - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) - else if (durq .eq. 'r') then - icrdat(ncrd) = ibset(icrdat(ncrd),24) - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) - else if (durq .eq. 'i') then -c -c Midi-only accidental on chord note -c - icrdat(ncrd) = ibset(icrdat(ncrd),27) - else if (durq .eq. 'd') then -c -c Must keep 'd' optional (backward compatibility), unless it is moved! -c - if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then -c -c move a dot, unless next char is not part of a number -c - if (index('0123456789.',lineq(iccount+2:iccount+2)) - * .eq. 0) go to 25 - icrdat(ncrd) = ibset(icrdat(ncrd),26) - call getchar(lineq,iccount,durq) - iccount=iccount+1 - call readnum(lineq,iccount,dumq,fnum) - if (durq .eq. '+') then - icrdot(ncrd) = ior(icrdot(ncrd),nint(fnum*10)+64) - else - icrdot(ncrd) = ior(icrdot(ncrd),-nint(fnum*10)+64) - end if - if (index('+-',dumq) .gt. 0) then -c -c Vertical shift specified also -c - iccount=iccount+1 - call readnum(lineq,iccount,durq,fnum) - if (dumq .eq. '+') then - ifnum = nint(fnum*10)+64 - else - ifnum = -nint(fnum*10)+64 - end if - else - ifnum = 64 - end if - icrdot(ncrd) = ior(icrdot(ncrd),ishft(ifnum,7)) - iccount = iccount-1 - end if - else -c -c must be a single digit, save it in ioct -c - numnum = 1 - ioct = ndx-7 - end if - go to 25 - end if - if (numnum .eq. 1) then - lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) - else - lastlev = lastlev-3 - * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) - end if - icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12)) - do 44 npreslur = npreslur , 1 , -1 - call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) -c -c Set level for chord note. -c Initially I assigned the slur(s) to next note, so fix. -c - islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),0) - islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),0) - isdat2(nsdat-npreslur+1) = ibset(isdat2(nsdat-npreslur+1),0) - call setbits(isdat1(nsdat-npreslur+1),8,3, - * igetbits(isdat1(nsdat-npreslur+1),8,3)-1) -44 continue - if (notcrd) then -c -c This is the first chord note in this chord. -c - minlev = min(nolev(ivx,nnl(ivx)),lastlev) - maxlev = max(nolev(ivx,nnl(ivx)),lastlev) - else - minlev = min(minlev,lastlev) - maxlev = max(maxlev,lastlev) - end if - notcrd = .false. - else if (charq .eq. 'G') then - call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, - * lastlev,iv,nv) - continue -c -c Grace, comes *before* main note: -c UNLESS there's an 'A' or 'W' after the 'G' -c ngrace = # of grace note groups so far in block -c ivg(ngrace), ipg(ngrace) -c nng(ngrace) = # of notes in this group: default = 1 -c ngstrt(ngrace) = starting position in nolevg of levels for this grace -c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' -c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' -c slurg(ngrace) = logical for slur; default F, input 's' -c slashg(ngrace) = T if slash; default is F, input 'x' -c These data MUST precede note name of first note -c nolevg, naccg: lists of levels and accid's, indexed as described above. -c -c ngrace = ngrace+1 -c ivg(ngrace) = ivx -c ipg(ngrace) = nnl(ivx)+1 -c if (ngrace .eq. 1) then -c ngstrt(ngrace) = 1 -c else -c ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1) -c end if -c islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4) -c nng(ngrace) = 1 -c multg(ngrace) = 1 -c upg(ngrace) = .true. -c slurg(ngrace) = .false. -c slashg(ngrace) = .false. -c18 call getchar(lineq,iccount,charq) -c if (index('WA',charq) .gt. 0) then -cc -cc Grace is on note that was already done, so shift flags forward one note. -cc This puts flag on actual note with grace; later for W will go ahead one more. -cc -c ipg(ngrace) = nnl(ivx) -c islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4) -c islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4) -c if (slurg(ngrace)) -c * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24) -c if (charq .eq. 'A') then -cc -cc close After, clear way-after bit, to ensure priority of most recent A/W -cc -c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29) -c else -cc -cc Way after; later assign to following note, and position like normal grace. -cc -c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31) -c end if -c else if (charq .eq. 'm') then -c call getchar(lineq,iccount,charq) -c multg(ngrace) = ichar(charq)-48 -c else if (index('123456789',charq) .gt. 0) then -c call readnum(lineq,iccount,durq,fnum) -c iccount = iccount-1 -c nng(ngrace) = nint(fnum) -c else if (charq .eq. 'l') then -c upg(ngrace) = .false. -c else if (charq .eq. 's') then -c slurg(ngrace) = .true. -c if (nnl(ivx) .gt. 0) then -cc -cc If A- or W-grace, set signal to start slur on main note. -cc -c if(btest(ipl(ivx,nnl(ivx)),31) .or. -c * btest(ipl(ivx,nnl(ivx)),29)) -c * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24) -c end if -c else if (charq .eq. 'x') then -c slashg(ngrace) = .true. -c else if (charq .eq. 'u') then -c else if (charq .eq. 'X') then -cc -cc Space before main note of grace. Number will come next. -cc -c iccount = iccount+1 -c call readnum(lineq,iccount,durq,graspace(ngrace)) -c iccount = iccount-1 -c end if -c if (index('abcdefg',charq) .eq. 0) go to 18 -cc -cc At this point, charq is first note name in grace -cc -c do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1 -c naccg(ing) = 0 -c ioct = 0 -c if (ing .gt. ngstrt(ngrace)) then -c55 call getchar(lineq,iccount,charq) -c if (charq .eq. ' ') go to 55 -c endif -c iclastlev = 0 -c9 call getchar(lineq,iccount,durq) -c if (durq .ne. ' ') then -c if (durq.eq.'+') then -c lastlev = lastlev+7 -c iclastlev = iclastlev+7 -c else if (durq.eq.'-') then -c lastlev = lastlev-7 -c iclastlev = iclastlev-7 -c else if (index('fsn',durq) .gt. 0) then -c if (naccg(ing) .eq. 0) then -c naccg(ing) = index('fsn',durq) -c else -cc -cc Double accidental -cc -c naccg(ing) = ibset(naccg(ing),2) -c end if -c else -c ioct = ichar(durq)-48 -c end if -c go to 9 -c end if -c if (ioct .gt. 0) then -c lastlev = ifnolev(charq,ioct) -c else -c if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then -c if (ivx .le. nv) then -c kv = 1 -c else -c kv = 2 -c end if -c lastlev = ndlev(iv,kv)+iclastlev -c end if -c lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7) -c end if -c nolevg(ing) = lastlev -c19 continue -cc -cc Grace could come before first note of block, so reset end level. -cc -c if (nnl(ivx).eq.0) then -c if (ivx .le. nv) then -c kv = 1 -c else -c kv = 2 -c end if -c ndlev(iv,kv) = lastlev -c end if - else if (charq .eq. sq) then -c -c Literal TeX string -c - call littex(islur,nnl(ivx)+1,ivx,topmods,lineq,iccount) - else if (charq .eq. 'o') then -c -c Ornament on non-xtup note. Symbol must come AFTER the affected note -c - if (notcrd) then - nole = nolev(ivx,nnl(ivx)) - else - nole = iand(127,ishft(icrdat(ncrd),-12)) - end if - call getorn(lineq,iccount,iornq(ivx,nnl(ivx)), - * iornq(ivx,0),ornrpt,noffseg,nnl(ivx),ivx, - * .true.,notcrd,nole) - else if (index('st(){}',charq) .gt. 0) then - nnlivx = nnl(ivx) - if (charq.eq.'(' .or. charq.eq.'{') then -c -c Detect preslur on normal non-chord note -c - nnlivx = nnlivx+1 - npreslur = npreslur+1 - end if - islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0) - if (charq.eq.'t') - * islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),1) - if (ivx .le. nv) then - kv = 1 - else - kv = 2 - end if - if (fontslur) then - call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3, - * nsdat,notcrd,nolev(ivx,nnlivx),charq) - else - call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3, - * isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq) - end if - else if (charq .eq. '?') then -c -c Arpeggio -c - if (btest(ipl(ivx,nnl(ivx)),10)) then -c -c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note -c of chord, will not set icrdat(25), but iornq(27) -c - icrdat(ncrd) = ibset(icrdat(ncrd),25) - else - iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),27) - end if -c -c Check for shift -c - call getchar(lineq,iccount,durq) - if (durq .eq. ' ') then - iccount = iccount-1 - else -c -c durq must be "-" -c - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 -c -c record the shift -c - NumArpShift = NumArpShift+1 - IvArpShift(NumArpShift) = ivx - IpArpShift(NumArpShift) = nnl(ivx) - ArpShift(NumArpShift) = fnum - end if - else if (index('0123456789#-nx_',charq) .gt. 0) then -c -c We have a figure. Must come AFTER the note it goes under -c - - ivf = 1 - if (ivx .gt. 1) then - if (ivxfig2 .eq. 0) then - ivxfig2 = ivx - else if (ivx .ne. ivxfig2) then - print* - print*,'Figures not allowed in >1 voice above first' - stop - end if - ivf = 2 - end if - nfig1 = nfigs(ivf)+1 - call getfig(itoff(ivf,nfig1),charq,lineq,iccount, - * isfig(ivf,nnl(ivx)),itfig(ivf,nfig1),itsofar(ivx), - * nodur(ivx,nnl(ivx)),figq(ivf,nfig1), - * ivupfig(ivf,nfig1),nfigs(ivf)) - else if (charq .eq. '[') then -c -c Start forced beam. Record barno & time since start of inp. blk. Set signal -c - nfb(ivx) = nfb(ivx)+1 - fbon = .true. - ulfbq(ivx,nfb(ivx)) = 'x' - t1fb(ivx,nfb(ivx)) = itsofar(ivx) - nadj = 0 - if (autofbon) then - autofbon = .false. - end if -17 call getchar(lineq,iccount,charq) - if (index('ulf',charq) .gt. 0) then - ulfbq(ivx,nfb(ivx)) = charq - go to 17 - else if (charq .eq. 'j') then -c -c Continuing a jumped beam here -c - irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),24) -c -c Set flag to watch for END of this forced beam, so can set flag rest(30) on -c NEXT note as signal to start a new notes group there. -c - isbj2 = .true. - go to 17 - else if (charq .eq. 'h') then - islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),2) - go to 17 - else if (charq .eq. 'm') then -c -c Force multiplicity. Next input is digit -c - call getchar(lineq,iccount,charq) - islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),21) - call setbits(islur(ivx,nnl(ivx)+1),3,22,ichar(charq)-48) - go to 17 - else if (charq .eq. ':') then -c -c Start auto forced beam pattern -c - autofbon = .true. -c -c When forced later beam ends, check whether tautofv <=0; if so set it. -c - tautofb = -itsofar(ivx) - t1autofb = itsofar(ivx) - go to 17 - else if (charq .ne. ' ') then -c -c Must be '+/-' for height or slope shift -c - nadj = nadj+1 -c -c nadj = 1,2, or 3 for normal start level, slope, or beam-thk start level. -c - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - iadj = nint(fnum) - if (charq .eq. '-') iadj = -iadj - if (nadj .eq. 1) then -c -c This is a level shift. Note if 0 was entered, iadj = 30 -c - call setbits(ipl(ivx,nnl(ivx)+1),6,11,iadj+30) - else if (nadj .eq. 2) then -c -c Must be a slope shift -c - call setbits(ipl(ivx,nnl(ivx)+1),6,17,iadj+30) - else -c -c Beam-thk fine tune -c - call setbits(islur(ivx,nnl(ivx)+1),2,27,iadj) - end if - go to 17 - end if - else if (charq .eq. ']') then - if (autofbon .and. tautofb.lt.tol) then - tautofb=itsofar(ivx)+tautofb - end if - call getchar(lineq,iccount,charq) - if (index('j ',charq) .gt. 0) then -c -c Since ']' comes AFTER note, itsofar has been updated. Set ending signal. -c - t2fb(ivx,nfb(ivx)) = itsofar(ivx) - fbon = .false. - if (charq .eq. 'j') - * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),23) - if (isbj2) then -c -c This is the end of a fb segment of a jump beam. Set flag on NEXT note to -c force start of new notes group, provided this is not last note in bar. -c - if (mod(itsofar(ivx),lenbar) .ne. 0) - * irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),30) - isbj2 = .false. - end if - else if (charq .eq. '[') then -c -c Multiplicity down-up signal -c - islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),20) - else if (charq .eq. '-') then -c -c Set signals for gap in single-slope beam [...]-[...] -c - nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),20) - nacc(ivx,nnl(ivx)+1) = ibset(nacc(ivx,nnl(ivx)+1),21) -c -c Next two characters must be "[ ". Skip over them. -c - iccount = iccount+2 - end if - else if (charq .eq. 'D') then - call getdyn(ivx,nnl(ivx),irest(ivx,nnl(ivx)), - * iornq(ivx,nnl(ivx)),lineq,iccount) - else if (charq .eq. 'h') then -c -c Heading or height. For heading, only OK if at start of block -c Check whether at beginning of a block -c - if (iv.ne.1 .or. nnl(1).ne.0) then - print*,'You entered "h" not at beginning of block' - call stop1() - end if - call getchar(lineq,iccount,durq) - ihdvrt = 0 - if (index('+-',durq) .gt. 0) then -c -c Vertical offset -c - iccount = iccount+1 - call readnum(lineq,iccount,charq,fnum) - ihdvrt = fnum+.1 - if (durq .eq. '-') ihdvrt = -ihdvrt - durq = charq - end if - if (durq .ne. ' ') then -c -c Height symbol. Read past (until next blank) -c -3 call getchar(lineq,iccount,durq) - if (durq .ne. ' ') go to 3 - else -c -c Set flag for header & read it in -c - ihdht = 16 - call getbuf(headrq) - iccount = 128 - end if - else if (charq .eq. 'L') then -c -c Linebreak, already handled in pmxa, but check for movement break -c - iccount = iccount+1 - call readnum(lineq,iccount,durq,fmovbrk) - if (durq .eq. 'P') then - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - end if - if (durq .eq. 'M') then - movbrk = nint(fmovbrk) - movgap = 0 - parmov = -1. - call getchar(lineq,iccount,durq) -31 if (durq .eq. '+') then -c -c Get vertical space (\internotes) -c - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - movgap = nint(fnum) - go to 31 - else if (durq .eq. 'i') then - iccount = iccount+1 - call readnum(lineq,iccount,durq,parmov) - go to 31 - else if (durq .eq. 'c') then - nobar1 = .true. - call getchar(lineq,iccount,durq) - go to 31 - else if (durq .eq. 'r') then -c -c "rename" can be set on or off. -c - call getchar(lineq,iccount,durq) - rename = durq.eq.'+' - call getchar(lineq,iccount,durq) - go to 31 - else if (durq .eq. 'n') then -c -c Change # of voices. Input ninow, iiorig(1...ninow). Will use names, -c staves per inst. and clefs corr. to iiorig in original list of instruments. -c - nvold = nv - nv = 0 - rename = .true. - call getchar(lineq,iccount,durq) - if (durq .eq. ':') then - iccount = iccount+2 - read(lineq(iccount-1:iccount),'(i2)')ninow - else - ninow = ichar(durq)-48 - end if - iiv = 0 - do 63 iinow = 1 , ninow - call getchar(lineq,iccount,durq) - if (durq .eq. ':') then - iccount = iccount+2 - read(lineq(iccount-1:iccount),'(i2)')iiorig(iinow) - else - iiorig(iinow) = ichar(durq)-48 - end if - nspern(iinow) = nsperi(iiorig(iinow)) - nv = nv+nspern(iinow) - sepsymq(iiv+nspern(iinow)) = '&' - if (nspern(iinow) .gt. 1) then - do 64 iis = 1 , nspern(iinow)-1 - sepsymq(iiv+iis) = '|' -64 continue - end if - iiv = iiv+nspern(iinow) -63 continue - if (islast) then - if (ninow .lt. 10) then - write(11,'(a)')sq//'newnoi{'//chax(ninow+48)//'}%' - else - write(11,'(a8,i2,a2)')sq//'newnoi{',ninow,'}%' - end if - end if - if (nv.eq.1 .and. nvold.gt.1) then - if (islast) write(11,'(a)')sq//'nostartrule' - else if (nv.gt.1 .and. nvold.eq.1) then - if (islast) write(11,'(a)')sq//'startrule' - end if - iiv = 0 - do 60 iinow = 1 , ninow - do 61 iis = 1 , nspern(iinow) - iiv = iiv+1 -c -c May not really need to re-enter clefs, but it's easier to program since -c clef names are not saved but are needed in newvoice to set ncmidcc. -c - call getchar(lineq,iccount,clefq(iiv)) - call newvoice(iiv,clefq(iiv),.true.) - if (nspern(iinow) .eq. 1) then - hdlndq = chax(48+numclef(clefq(iiv))) - lclf = 1 - else if (iis .eq. 1) then - hdlndq = '{'//chax(48+numclef(clefq(iiv))) - lclf = 2 - else if (iis .lt. nspern(iinow)) then - hdlndq = hdlndq(1:lclf)//chax(48+numclef(clefq(iiv))) - lclf = lclf+1 - else - hdlndq = - * hdlndq(1:lclf)//chax(48+numclef(clefq(iiv)))//'}' - lclf = lclf+2 - end if -61 continue -c -c setstaffs & setclef go by instrument, not voice -c - if (islast) then - if (iinow .lt. 10) then - write(11,'(a)')sq//'setstaffs' - * //chax(48+iinow)//chax(48+nspern(iinow))//'%' - write(11,'(a)')sq//'setclef'//chax(48+iinow) - * //hdlndq(1:lclf)//'%' - else - write(11,'(a11,i2,a)')sq//'setstaffs{',iinow, - * '}'//chax(48+nspern(iinow))//'%' - write(11,'(a9,i2,a)')sq//'setclef{',iinow, - * '}'//hdlndq(1:lclf)//'%' - end if - end if -60 continue -c -c Loop back up, this may not be last option in M. Note flow out if durq=' ' -c - call getchar(lineq,iccount,durq) - go to 31 - end if -c -c Write instrument names -c - if (.not.rename) then - do 62 iinst = 1 , ninow - if (islast) then - if (iinst .lt. 10) then - write(11,'(a8,i1,a3)')sq//'setname',iinst,'{}%' - else - write(11,'(a9,i2,a4)')sq//'setname{',iinst,'}{}%' - end if - end if -62 continue - else - do 65 iinst = 1 , ninow - if (islast) then - if (iinst .lt. 10) then - write(11,'(a8,i1,a)')sq//'setname',iinst,'{'// - * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%' - else - write(11,'(a9,i2,a)')sq//'setname{',iinst,'}{'// - * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%' - end if - end if -65 continue - rename = .false. - end if - end if - else if (charq .eq.'|' ) then -c -c End of bar symbol. Check about end of bar hardspace. -c - if (btest(iornq(ivx,nnl(ivx)+1),26)) then -c -c There was a hardspace followed by a bar line. Remove it from the hardspace -c list, store with shifts instead, set special bit. Need to repeat this code -c at '/'. -c - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18) - nudoff(ivx) = nudoff(ivx)+1 - udoff(ivx,nudoff(ivx)) = udsp(nudsp) - nudsp = nudsp-1 - iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26) - end if - else if (index('wS',charq) .gt. 0) then -c -c Width symbol or new nsyst. Read past (until blank) -c -4 call getchar(lineq,iccount,durq) - if (durq .ne. ' ') go to 4 - else if (charq .eq. 'l') then -c -c Lower string. Only OK if at start of block -c Check whether at beginning of a block -c - if (iv.ne.1 .or. nnl(1).ne.0) then - print*,'You entered "l" not at beginning of block' - call stop1() - end if -c -c Set flag for lower string & read it in -c - lower = .true. - call getbuf(lowerq) - iccount = 128 - else if (charq .eq. 'm') then -c -c Meter change. Only allow at beginning of block. -c mtrnuml, mtrdenl (logical) and p (printable) will be input. -c mtrnuml=0 initially. (In common) -c -c Check whether at beginning of a block -c - if (iv.ne.1 .or. nnl(1).ne.0) then - print*,'You entered "m" not at beginning of block' - call stop1() - end if - call readmeter(lineq,iccount,mtrnuml,mtrdenl) - call readmeter(lineq,iccount,mtrnmp,mtrdnp) - lenbeat = ifnodur(mtrdenl,'x') - if (mtrdenl .eq. 2) lenbeat = 16 - lenbar = mtrnuml*lenbeat - if (mtrdenl .eq. 2) lenbar = lenbar*2 - lenb1 = lenbar - lenb0 = 0 - if (ismidi) call midievent('m',mtrnuml,mtrdenl) - else if (charq .eq. 'C') then -c -c Clef change on next note. Set bits 11-15. Won't allow in 2nd line of music. -c - if (nnl(iv) .gt. 0) ncc(iv) = ncc(iv)+1 - tcc(iv,ncc(iv)) = itsofar(iv) - isl = ibset(islur(iv,nnl(iv)+1),11) - call getchar(lineq,iccount,durq) -c -c Store clef number, or 7 if clef number = 9 (French violin clef) -c - isl = ior(isl,ishft(min(numclef(durq),7),12)) - ncmidcc(iv,ncc(iv)) = ncmidf(durq) -c -c Set marker on note with lowest voice # starting at same time. -c - if (iv .eq. 1) then - isl = ibset(isl,15) - else - do 13 iiv = 1 , iv - nnliiv = nnl(iiv) - if (iiv .eq. iv) nnliiv = nnliiv+1 - itother = 0 - do 14 iip = 1 , nnliiv - if (itother .lt. itsofar(iv)) then - itother = itother+nodur(iiv,iip) - go to 14 - else if (itother .eq. itsofar(iv)) then - islur(iiv,iip) = ibset(islur(iiv,iip),15) - go to 15 - end if -14 continue -13 continue -15 continue - end if -c -c Need 'or' since may have set bit 15 in the above loop -c - islur(iv,nnl(iv)+1) = ior(isl,islur(iv,nnl(iv)+1)) - else if (charq .eq. 'R') then -c -c Repeats. set bits 5, 6, and/or 8 of islur(1,ip+1) -c -10 call getchar(lineq,iccount,durq) -c -c Save designator in case it's a terminal Rr or Rd -c - if (durq .eq. 'l') then - islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),5) - go to 10 - else if (index('rdDbz',durq) .gt. 0) then - if (durq .eq. 'r') then - islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),6) - else if (durq .eq. 'd') then - islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),8) - else if (durq .eq. 'D') then - islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),26) - else if (durq .eq. 'b') then - islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),25) - else if (durq .eq. 'z') then - iornq(1,nnl(1)+1) = ibset(iornq(1,nnl(1)+1),29) - end if - rptprev = .true. - rptfq1 = durq - go to 10 - end if - else if (charq .eq. 'V') then -c -c Ending -c - nnnl = nnl(1)+1 - lvoltxt = 0 -11 call getchar(lineq,iccount,durq) - if (durq.eq.'b' .or. durq .eq.'x') then -c -c End Volta, set bit9, and bit10 on if 'b' (end w/ box) -c - islur(1,nnnl) = ibset(islur(1,nnnl),9) - if (durq .eq. 'b') islur(1,nnnl) = ibset(islur(1,nnnl),10) - go to 11 - else if (durq .ne. ' ') then -c -c Start volta; Get text -c - if (lvoltxt .eq. 0) then -c -c First character for text -c - lvoltxt = 1 - islur(1,nnnl) = ibset(islur(1,nnnl),7) - nvolt = nvolt+1 - voltxtq(nvolt) = durq - else - voltxtq(nvolt) = voltxtq(nvolt)(1:lvoltxt)//durq - lvoltxt = lvoltxt+1 - end if - go to 11 - end if - else if (charq .eq. 'B') then - bcspec = .not.bcspec - else if (charq .eq. 'P') then -c -c Page numbers. Print stuff right now. -c - npg1 = 0 -c -c Will use ltopnam to signal whether there's a centered heading -c - ltopnam = 0 - ipg1r = 0 -16 call getchar(lineq,iccount,durq) - if (ichar(durq).ge.48 .and. ichar(durq).le.57) then - npg1 = npg1*10+ichar(durq)-48 - go to 16 - else if (durq .eq. 'l') then - if (npg1.eq.0 .or. mod(npg1,2).eq.1) ipg1r = 1 - go to 16 - else if (durq .eq. 'r') then - if (npg1.gt.0 .and. mod(npg1,2).eq.0) ipg1r = 1 - go to 16 - else if (durq .eq. 'c') then -c -c Top-centered name. Assume this is last option. Read the name. -c May surround name in double quotes (to allow blanks). -c - call getchar(lineq,iccount,durq) - if (durq .eq. ' ') then - ltopnam = lenstr(cheadq,60) - else - namstrt = iccount - if (durq .eq. '"') then -c -c Using quote delimiters. -c - quoted = .true. - namstrt = namstrt+1 - else - quoted = .false. - end if - do 35 iccount = namstrt+1, 128 - if ((quoted .and. lineq(iccount:iccount) .eq. '"') .or. - * (.not.quoted .and. lineq(iccount:iccount) .eq. ' ')) - * go to 36 -c -c On exit, iccount is OK, and name is in (namstrt:iccount-1) -c -35 continue - print*,'Awww, cmon, should not be here.' - call stop1() -36 continue - ltopnam = iccount-namstrt - cheadq = lineq(namstrt:iccount-1) - end if - end if -c -c Done getting data, now assemble the command -c - if (npg1.eq.0) npg1=1 -c -c 2/23/03 Don't use \atnextline if on first page and only one system -c -c if (ipage.gt.1 .or. nsystp(1).gt.1) then - hdlndq = sq//'def'//sq//'atnextline{'//sq//'toppageno{' - lhead = 27 -c else -c hdlndq = sq//'toppageno{' -c lhead = 11 -c end if - if (npg1 .lt. 10) then -c -c Note we are overwriting the last "{" -c - write(hdlndq(lhead:lhead),'(i1)')npg1 - else if (npg1 .lt. 100) then - lhead = lhead+3 - write(hdlndq(lhead-2:lhead),'(i2,a1)')npg1,'}' - else - lhead = lhead+4 - write(hdlndq(lhead-3:lhead),'(i3,a1)')npg1,'}' - end if - hdlndq = hdlndq(1:lhead)//chax(ipg1r+48)//'{' - lhead = lhead+2 -c if (ipage.gt.1 .or. nsystp(1).gt.1) then - if (ltopnam .eq. 0) then - if (islast) write(11,'(a)')hdlndq(1:lhead)//'}}%' - else - if (islast) - * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}}%' - end if -c else -c if (ltopnam .eq. 0) then -c if (islast) write(11,'(a)')hdlndq(1:lhead)//'}%' -c else -c if (islast) -c * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}%' -c end if -c end if - else if (charq .eq. 'W') then -c -c Just eat the number that must follow, it was used in pmxa -c - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - else if (charq .eq. 'T') then - headlog = .true. - inhead = 0 - call getchar(lineq,iccount,durq) - if (durq .eq. 'i') then - call getbuf(instrq) -c -c A kluge for parts from separate score file for later movements. -c - if (instrq(1:1) .eq. ' ') headlog = .false. - cheadq = instrq - else if (durq .eq. 't') then - call getchar(lineq,iccount,durq) -c -c Optionally can include extra vertical \internotes above inbothd -c - if (index('-+0123456789',durq) .gt. 0) then - ipm = 1 - if (index('+-',durq) .gt. 0) then -c -c Don't trust readnum to round this negative integer properly -c - iccount = iccount+1 - if (durq .eq. '-') ipm = -1 - end if - call readnum(lineq,iccount,durq,fnum) - inhead = ipm*nint(fnum) - end if - call getbuf(titleq) - else - call getbuf(compoq) - end if - inhead = inhead+inbothd - iccount = 128 - else if (charq .eq. 'A') then -c -c Accidental handling etc. -c -27 call getchar(lineq,iccount,durq) - if (durq .eq. 'r') then - if (islast) then - relacc = .true. - write(11,'(a)')sq//'relativeaccid%' - end if - else if (durq .eq. 's') then - bacfac = 1.e6 - else if (durq .eq. 'b') then - if (islast) write(11,'(a)')sq//'bigaccid%' - accfac = bacfac - else if (durq .eq. 'a') then - call getchar(lineq,iccount,durq) - call readnum(lineq,iccount,durq,fnum) - iccount = iccount-1 - else if (durq .eq. 'i') then - call getchar(lineq,iccount,durq) - call readnum(lineq,iccount,durq,tintstf) - if (.not.firstgulp) fintstf = tintstf -c -c Local corrections for first page were handled by pmxa -c - iccount = iccount-1 - else if (durq .eq. 'I') then - call getchar(lineq,iccount,durq) - call readnum(lineq,iccount,durq,gintstf) - iccount = iccount-1 - else if (durq .eq. 'd') then - lowdot = .true. - else if (durq .eq. 'o') then - continue - else if (durq .eq. 'S') then - do 50 iiv = 1 , nv - call getchar(lineq,iccount,durq) - if (index('-s',durq) .gt. 0) then - fullsize(iiv) = 0.8 - else if (durq .eq. 't') then - fullsize(iiv) = 0.64 - else - fullsize(ivx) = 1.0 - end if -50 continue - else if (durq .eq. 'e') then -c -c Line-spacing equalization -c - equalize = .true. -c -c The following redefinition of \parskip was put into pmx.tex in version 2.25 or so. -c But it causes problems with some older scores and when excerpts are combined -c with LaTeX. So as of 2.352 we write it here. -c - write(11,'(a)')sq//'global'//sq//'parskip 0pt plus 12'//sq - * //'Interligne minus 99'//sq//'Interligne%' - tempq = sepsymq(1) - lentemp = 1 - do 51 iiv = 2 , nv-1 - tempq = tempq(1:lentemp)//sepsymq(iiv) - lentemp = lentemp+1 -51 continue - write(11,'(a)')sq//'def'//sq//'upstrut{'//sq//'znotes' - * //tempq(1:lentemp)//sq//'zcharnote{'//sq//'upamt}{~}' - * //sq//'en}%' - else if (durq .eq. 'v') then -c -c Toggle usevshrink -c - usevshrink = .not.usevshrink - else if (durq .eq.'p') then -c -c Postscript slurs. fontslur is already false (set in g1etnote) -c - if (.not.WrotePsslurDefaults) then -c -c Set postscrirpt slur adjustment defaults -c - write(11,'(a)')sq//'Nosluradjust'//sq//'Notieadjust' - * //sq//'nohalfties' - WrotePsslurDefaults = .true. - end if -52 continue - call g1etchar(lineq,iccount,durq) ! might be "+", "-", "h" or "l" - if (index('+-',durq) .gt. 0) then -c -c Characters to change defaults for ps slurs -c - call g1etchar(lineq,iccount,charq) ! charq will be "s,t,h,c" - if (durq .eq. '+') then - if (charq .eq. 's') then - write(11,'(a)')sq//'Sluradjust' - else if (charq .eq. 't') then - write(11,'(a)')sq//'Tieadjust' - else if (charq .eq. 'h') then - write(11,'(a)')sq//'halfties' - else - SlurCurve = SlurCurve + 1 - if (SlurCurve .gt. 3.1) then - call printl('WARNING!') - call printl - * ('Default slur curvature advanced past HH, resetting') - SlurCurve = 3 - end if - end if - else - if (charq .eq. 's') then - write(11,'(a)')sq//'Nosluradjust' - else if (charq .eq. 't') then - write(11,'(a)')sq//'Notieadjust' - else if (charq .eq. 'h') then - write(11,'(a)')sq//'nohalfties' - else - SlurCurve = SlurCurve - 1 - if (SlurCurve .lt. -1.1) then - call printl('WARNING!') - call printl( - * 'Default slur curvature decremented below f, resetting') - SlurCurve = -1 - end if - end if - end if - go to 52 ! Check for another set of default changes - else if (durq .eq. 'l') then -c -c Set optional linebreak ties -c - OptLineBreakTies = .true. - go to 52 - else if (durq .eq. 'h') then -c -c Set flag to write header special on every page -c - HeaderSpecial = .true. - go to 52 - else - iccount = iccount-1 - end if - else if (durq .eq. 'K') then -c -c Toggle keyboard rest placement flag -c - kbdrests = .not.kbdrests - end if -c if (durq .eq. 'N') then - if (index('NR',durq) .gt. 0) then -c -c Override default part names for scor2prt, or normal include file. -c Just bypass rest of input line -c - iccount = 128 - else if (durq .ne. ' ') then - go to 27 - end if - else if (charq .eq. 'K') then - call getchar(lineq,iccount,durq) - if (durq .ne. 'i') then -c -c Normal, full-score key change and/or transposition -c - num1 = 44-ichar(durq) - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - num1 = num1*nint(fnum) -c -c On exit, durq='+','-'. But only need isig if after start, else done in pmxa -c - iccount = iccount+1 - call readnum(lineq,iccount,charq,fnum) - if (num1 .eq. 0) then -c -c Key change, not transposition. -c - ipl(ivx,nnl(ivx)+1) = ibset(ipl(ivx,nnl(ivx)+1),28) - lastisig = isig - isig = nint(fnum) - if (durq .eq. '-') isig = -isig - isig = isig+idsig - if (ismidi) call midievent('k',isig,0) - else -c -c num1 .ne. 0, so transposition, so must be at beginning. isig came with K... -c but was passed to pmxb through pmxtex.dat. isig0 comes from setup data -c (signature before transposition). idsig must be added to future key changes. -c - jv = 0 - do while (jv .lt. nm) - jv = jv+1 - iTransAmt(jv) = num1 - end do - idsig = isig-isig0 - end if - else -c -c Instrument specific transposition. - - call GetiTransInfo(.false.,ibarcnt,lineq,iccount, - * ibaroff,nbars,noinst,iv) - end if - else if (charq .eq. '/') then - if (btest(iornq(ivx,nnl(ivx)+1),26)) then -c -c There was a hardspace followed by end of block. Remove it from the hardspace -c list, store with shifts instead, set special bit. This code also at '|' -c - irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18) - nudoff(ivx) = nudoff(ivx)+1 - udoff(ivx,nudoff(ivx)) = udsp(nudsp) - nudsp = nudsp-1 - iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26) - end if - call getchar(lineq,iccount,durq) -c -c Save ending note level: -c - if (ivx .le. nv) then -c -c This is the first line of music on this staff. If previous block had only 1 -c voice, save last pitch from line 1 of prev. block to line 2, in case a -c 2nd line is started just below -c - if (.not.was2(iv)) ndlev(iv,2) = ndlev(iv,1) - was2(iv) = .false. - ndlev(iv,1) = lastlev - else -c -c This is the 2nd line of music on this staff. -c - was2(iv) = .true. - ndlev(iv,2) = lastlev - end if - if (durq .eq. ' ' .and. iv.eq.nv) then -c -c End of input block -c - loop = .false. - else -c -c Start a new line of music -c - if (lenb0.ne.0 .and. firstgulp) lenbar = lenb0 - nbars = 0 - if (durq .eq. ' ') then -c -c New line of music is on next staff -c - iv = iv+1 - ivx = iv - else -c -c durq must be 2nd '/'. New line of music is on same staff. Set up for it -c - ivx = nv+1 - do 23 iiv = 1 , nv - if (nvmx(iiv) .eq. 2) ivx = ivx+1 -23 continue - nvmx(iv) = 2 - ivmx(iv,2) = ivx - itsofar(ivx) = 0 - nnl(ivx) = 0 - nfb(ivx) = 0 - nudoff(ivx) = 0 - ndotmv(ivx) = 0 - do 24 j = 1 , 200 - irest(ivx,j) = 0 - islur(ivx,j) = 0 - nacc(ivx,j) = 0 - iornq(ivx,j) = 0 - ipl(ivx,j) = 0 - mult(ivx,j) = 0 -24 continue -c -c Go back and lower the rests in voice "a" that don't have over-ridden heights -c - do 26 j = 1 , nnl(iv) - if (btest(irest(iv,j),0) .and. nolev(iv,j).eq.0) - * nolev(iv,j) = -4 -26 continue - end if - end if - iccount = 128 - else if (charq .eq. 'X') then -c -c 3rd arg is only for termination of group shifts. Use "max" to avoid zero index, -c which only happens for normal X at block start, and we took special measures to -c keep group shifts for crossing block boundaries. -c - call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx))), - * shifton,wheadpt,iornq(ivx,nnl(ivx)+1),ivx, - * irest(ivx,nnl(ivx)+1),itsofar(ivx),0,0,0,' ',ndoub) - else if (charq .eq. 'I') then -c -c Midi controls. -c - call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, - * mtrdenl,.false.) - else if (charq .eq. 'M') then -c -c Macro action -c - call getchar(lineq,iccount,charq) - if (index('RS',charq) .gt. 0) then -c -c Record or save a macro. Get the number of the macro. -c - call getchar(lineq,iccount,durq) - call readnum(lineq,iccount,durq,fnum) - macnum = nint(fnum) - macuse = ibset(macuse,macnum) - if (charq .eq. 'R') then - call mrec1(lineq,iccount,ndxm) - else -c -c Save (Record but don't activate) -c -5 call mrec1(lineq,iccount,ndxm) - if (mrecord) then - call getbuf(lineq) - iccount = 0 - go to 5 - end if - iccount = iccount+ndxm+1 - end if - else if (charq .eq. 'P') then -c -c Playback the macro -c - call getchar(lineq,iccount,charq) - call readnum(lineq,iccount,durq,fnum) - macnum = nint(fnum) - icchold = iccount - lnholdq = lineq - iccount = 128 - ilmac = il1mac(macnum) - mplay = .true. - end if - else if (index(',.',charq) .gt. 0) then -c -c Continued rhythmic shortcut -c - idotform = index('. ,',charq) - if (idotform .eq. 1) then -c -c Check for start of forced beam on 2nd member of dotform=1 shortcut -c - if (fbon) then - if (t1fb(ivx,nfb(ivx)).eq.itsofar(ivx)) - * t1fb(ivx,nfb(ivx)) = - * t1fb(ivx,nfb(ivx))+nodur(ivx,nnl(ivx))/2 - end if -c -c Change duration of prior note -c - itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx)) - nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2 - itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) - end if - idotform = idotform+1 - numnum = 1 - cdot = .true. - go to 1 - end if - return - end - subroutine getorn(lineq,iccount,iornq,iornq0,ornrpt,noffseg, - * ip,ivx,noxtup,notcrd,nole) -c -c iornq: Main note. Do not alter if chord note, except turn on bit 23 -c iornq0: Store iorni + bit 23, in case of repeated ornaments -c iorni: Internal use, 1st 21 bits of iornq or icrdorn, dep. on notcrd. -c noffseg: horiz. offset for segno -c nole: level of note w/ orn, used to ID the note/orn if there's a level shift. -c - - common /comivxudorn/ivxudorn(63) - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - common /comcb/ nbc,ibcdata(36) - character*1 charq,durq - character*128 lineq - logical ornrpt,negseg,noxtup,notcrd -c -c Bits 0-13: (stmgx+Tupf._), 14: Down fermata, was F, 15: Trill w/o "tr", was U -c 16-18 Editorial sharp, flat, natural "oes,f,n"; 19-20: >^, 21 TBD -c - call getchar(lineq,iccount,charq) - if (index('bc',charq) .gt. 0) then -c -c caesura or breath, handle specially and exit. Set up data in ibcdata(1...nbc) -c ivx(0-3,28), ip(4-12), -c vshift (vshift+32 in bits 13-18), -c hshift (nint(10*vshift)+128 in bits 19-26) -c bit 27 = 0 if caesura, 1 if breath -c bit 28: 5th bit of ivx -c - iornq = ibset(iornq,28) - nbc = nbc+1 -c ibcdata(nbc) = ivx+16*ip - ibcdata(nbc) = mod(ivx,16)+16*ip - if (ivx.ge.16) ibcdata(nbc) = ibset(ibcdata(nbc),28) - if (charq .eq. 'b') ibcdata(nbc) = ibset(ibcdata(nbc),27) - call getchar(lineq,iccount,durq) - if (index('+-',durq) .gt. 0) then -c -c We have a vertical shift, get it -c - iccount = iccount+1 - call readnum(lineq,iccount,charq,fnum) - if (durq .eq. '-') fnum=-fnum - call setbits(ibcdata(nbc),6,13,nint(32+fnum)) - if (index('+-',charq) .gt. 0) then -c -c Horizontal shift, get it -c - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - if (charq .eq. '-') fnum=-fnum - call setbits(ibcdata(nbc),8,19,nint(10*fnum)+128) - end if - end if - return - end if -c -c Set signal on main note that some note at this time has ornament. ONLY used -c in beamstrt to activate further tests for whether ihornb is needed. -c - iornq = ibset(iornq,23) -c -c Isolate 21 bits defining exisiting ornaments -c - if (notcrd) then - iorni = iand(4194303,iornq) - else - iorni = iand(4194303,icrdorn(ncrd)) - end if - korn = index('stmgx+Tupf._)e:XXX>^',charq) - if (korn .ne. 15) iorni = ibset(iorni,korn) -c -c Note that korn=0 => charq='(', and we set bit 0. if "e" (14), alter later -c as follows: korn=16-18 for sfn, and or 21 for bare ?. -c When this if-block is done, korn will = bit# of actual ornament (unless "?"). -c - if (korn .eq. 15) then -c -cc Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-20 prev iornq -c Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21 prev iornq -c -c iorni = ior(iorni,iand(iornq0,1638383)) - iorni = ior(iorni,iand(iornq0,3735535)) - ornrpt = .false. - call getchar(lineq,iccount,durq) -c -c durq will be ' ' -c - else if (korn .eq. 14) then -c -c Editorial accidental -c - call getchar(lineq,iccount,durq) -c korn = 15+index('sfn',durq) - korn = 15+index('sfn?',durq) - if (korn .eq. 19) korn=21 - iorni = ibset(ibclr(iorni,14),korn) - call getchar(lineq,iccount,durq) - if (durq .eq. '?') then -c -c This is "oe[s|f|n]?". Set 21st bit also. -c - iorni = ibset(iorni,21) - korn = korn+6 - call getchar(lineq,iccount,durq) - end if -c iorni = ibset(ibclr(iorni,14),korn) - else if (korn.eq.4 .and. noxtup) then -c -c segno. Check in pmxa for just 1/block & notcrd. Get horiz. offset in points -c - noffseg = 0 - negseg = .false. - call getchar(lineq,iccount,durq) - if (durq .ne. ' ') then -c -c Segno shift is specified -c - if (durq .eq. '-') then - negseg = .true. - call getchar(lineq,iccount,durq) - end if - call readnum(lineq,iccount,durq,fnum) - noffseg = int(fnum) - if (negseg) noffseg = -noffseg - end if - else if (korn .eq. 7) then -c -c Trill. Check in pmxa for notcrd. Default is 1 noteskip long, with "tr" -c - ntrill = ntrill + 1 - ivtrill(ntrill) = ivx - iptrill(ntrill) = ip - xnsktr(ntrill) = 1. - call getchar(lineq,iccount,durq) - if (durq .eq. 't') then -c -c Convert to new internal symbol for non-'"tr" trill -c - korn = 15 - iorni = ibset(ibclr(iorni,7),15) - call getchar(lineq,iccount,durq) - end if - if (index('0123456789.',durq) .gt. 0) then -c -c We have a number for the length -c - call readnum(lineq,iccount,durq,xnsktr(ntrill)) - end if - else if (korn.eq.10 .and. noxtup) then -c -c Fermata -c - call getchar(lineq,iccount,durq) - if (durq .eq. 'd') then - korn = 14 - iorni = ibset(ibclr(iorni,10),14) - call getchar(lineq,iccount,durq) - end if - else - call getchar(lineq,iccount,durq) - end if - if (index('+- :',durq) .eq. 0) then - print*,'Unexpected character at end of ornament: ',durq - call stop1() - end if - if (index('+-',durq) .gt. 0) then -c -c Shift ornament up or down -c - nudorn = nudorn+1 -c -c Set bit 25 in iorni as a signal. This may not really be necessary. -c - iorni = ibset(iorni,25) -c -c Assemble info to put in kudorn(nudorn) Bits 0-7:ip, 8-11:ivx, 12-18:nolev, -c 19-24: type of ornament to be shifted, 25-30: shift+32, 31:h-shft present -c - xofforn = 44-ichar(durq) - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - iofforn = nint(xofforn*fnum) - kudorn(nudorn) = ip+ishft(mod(ivx,16),8)+ishft(nole,12) - * +ishft(korn,19)+ishft(iofforn+32,25) - ivxudorn(nudorn) = ivx - if (index('+-',durq) .gt. 0) then -c -c Horizontal shift -c - kudorn(nudorn) = ibset(kudorn(nudorn),31) - xofforn = 44-ichar(durq) - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - ornhshft(nudorn) = nint(xofforn*fnum) - end if - else if (durq .eq. ':') then -c -c Turn on repeated ornaments -c - ornrpt = .true. -c -c Save the ornament value just set -c - iornq0 = iorni - end if - if (notcrd) then - iornq = ior(iornq,iorni) - else - icrdorn(ncrd) = ior(icrdorn(ncrd),iorni) - end if - return - end - subroutine getpmxmod(global,includeq) -c -c If global=.true., checks for environment variable with path to pmx.mod. -c Then, if variable exists and points to pmx.mod, insert lines from -c pmx.mod into buffer -c If global=.false., checks for existence of includeq and uses it. -c -c lenbuf0 = total length of bufq on entry -c lbuf(i) = length of line (i) -c nlbuf = number of lines stored in bufq -c ilbuf = index of first line after setup stuff (on entry). In general, index of -c next line to be sucked from buffer. -c ilbufmod = counter for lines in pmx.mod as they are grabbed. -c Starts at ilbuf. Points to position of next line after -c pmx.mod stuff in bufq on exiting loop 1 -c ilbuff = transient counter for shifting operations -c ipbuf = on entry, points to last character in setup stuff. In general, points -c to last character of most recent line sucked from buffer. -c ipbufmod = points to last character of most recent inserted line -c from pmx.mod -c - parameter (maxblks=4000,nm=24) - common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, - * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 - logical lastchar,fbon,issegno,isheadr,isvolt - character*(*)includeq - character*80 pmxmoddirq - character*128 lnholdq - character*65536 bufq - integer*2 lbuf(maxblks) - common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq - logical fexist,global - line1pmxmod = ilbuf - if (.not.global) then - inquire(file=includeq,EXIST=fexist) -c -c Transfer includeq to temporary char variable with known length -c - pmxmoddirq = includeq - lpmxmoddirq = lenstr(pmxmoddirq,80) - print* - write(15,'()') - if (.not.fexist) then - call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq) - * //', checking further.') -c -c File named includeq doesn't not exist. Get directory from PMXMODDIR and -c see if it's there -c - call getenv('PMXMODDIR',pmxmoddirq) - lpmxmoddirq = lenstr(pmxmoddirq,80) - if (lpmxmoddirq. gt. 0) then - pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//includeq - lpmxmoddirq = lenstr(pmxmoddirq,80) - else - call printl( - * 'No other directory defined by PMXMODDIR, stopping') - call stop1() - end if - inquire(file=pmxmoddirq,EXIST=fexist) - if (.not.fexist) then - call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq) - * //', stopping.') - call stop1() - end if - end if - call printl('Opening normal include file ' - * //pmxmoddirq(1:lpmxmoddirq)) - open(18,file=pmxmoddirq) - else -c -c Check for existence of pmx.mod -c - call getenv('PMXMODDIR',pmxmoddirq) - lpmxmoddirq = lenstr(pmxmoddirq,80) - if (lpmxmoddirq .eq. 0) return - pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//'pmx.mod' - lpmxmoddirq = lpmxmoddirq+7 - inquire(file=pmxmoddirq,EXIST=fexist) - if (.not.fexist) return - call printl('Opening global include file ' - * //pmxmoddirq(1:lpmxmoddirq)) - open(18,file=pmxmoddirq(1:lpmxmoddirq)) - end if - call printl('Adding include data') -c -c Read lines in from pmx.mod one at a time -c - ipbufmod = ipbuf - lenbufmod = lenbuf0 - do 1 ilbufmod = ilbuf , maxblks - read(18,'(a)',end=3)lnholdq -c -c A line was read. Slide all existing lengths from here forward ahead by 1 -c - do 2 ilbuff = nlbuf , ilbufmod , -1 - lbuf(ilbuff+1) = lbuf(ilbuff) -2 continue -c -c Get length of line from include file -c - lenmodline = lenstr(lnholdq,128) - if (lenmodline .eq. 0) then -c -c Blank line. Make it a single blank with length 1 -c - lenmodline = 1 - lnholdq = ' ' - end if - lbuf(ilbufmod) = lenmodline - call printl(lnholdq(1:lenmodline)) -c -c Insert new stuff into bufq -c - bufq = bufq(1:ipbufmod)//lnholdq(1:lenmodline)// - * bufq(ipbufmod+1:lenbufmod) -c -c Update internal parameters -c - ipbufmod = ipbufmod+lbuf(ilbufmod) - lenbufmod = lenbufmod+lbuf(ilbufmod) - nlbuf = nlbuf+1 -1 continue -3 continue - call printl('Closing '//pmxmoddirq(1:lpmxmoddirq)) - close(18) - linesinpmxmod = linesinpmxmod+ilbufmod-ilbuf - lenbuf0 = lenbufmod -c -c Fix Andre's error reporting problem 101211 leading to log(neg#) due -c to nline being 2 bigger than it should be -c - nline=nline-2 -c - return - end - subroutine getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, - * xmtrnum0,npages,nsyst,musicsize,fracindent,istype0, - * inameq,clefq,sepsymq,pathnameq,lpath,isig0) - parameter (nm=24) - common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) - character*1 clefq(nm),sepsymq(nm) - character*40 pathnameq - character*79 inameq(nm) - character*128 lineq - logical istype0,newway,rename -c -c Get the first line -c - iccount = 0 -9 call getbuf(lineq) - if (lineq(1:1) .eq. '%') go to 9 - istype0 = lineq(1:3).eq.'---' - if (istype0) then -c -c Have TeX input until next line that starts with '---'. Save in scratch. -c - open(17,status='SCRATCH') -3 call getbuf(lineq) - if (lineq(1:3) .ne. '---') then - write(17,'(a)')lineq - go to 3 - end if -c -c Force a new line read on first call to readin -c - iccount = 128 - end if -c -c Here, lineq is first line w/ numerical setup data. -c - nv = nint(readin(lineq,iccount,nline)) - noinst = nint(readin(lineq,iccount,nline)) - newway = noinst.le.0 - if (newway) noinst = -noinst - do 2 iinst = 1 , noinst -c -c Seve # of staves per inst in case later drop some inst's. -c - if (newway) then -c -c Read in nvi for each instrument -c - nsperi(iinst) = nint(readin(lineq,iccount,nline)) - else if (iinst .gt. 1 ) then - nsperi(iinst) = 1 - else - nsperi(iinst) = nv-noinst+1 - end if - iiorig(iinst) = iinst - nspern(iinst) = nsperi(iinst) -2 continue - mtrnuml = nint(readin(lineq,iccount,nline)) - mtrdenl = nint(readin(lineq,iccount,nline)) -cc -cc Kluge to make mtrdenl work -cc -c if (mtrdenl .eq. 1) then -c mtrdenl = 2 -c mtrnuml = mtrnuml*2 -c end if - mtrnmp = nint(readin(lineq,iccount,nline)) - mtrdnp = nint(readin(lineq,iccount,nline)) - xmtrnum0 = readin(lineq,iccount,nline) -c -c Original key sig (before any trnasposition) in next position. Transposed -c sig for topfile was transferred thru pmxtex.dat. Need isig0 for key -c changes if transposed. -c - isig0 = nint(readin(lineq,iccount,nline)) - npages = nint(readin(lineq,iccount,nline)) - nsyst = nint(readin(lineq,iccount,nline)) - musicsize = nint(readin(lineq,iccount,nline)) - fracindent = readin(lineq,iccount,nline) -c -c Next noinst non-comment lines are names of instruments. -c - do 4 i = 1 , noinst -5 call getbuf(inameq(i)) - if (inameq(i)(1:1) .eq. '%') go to 5 -4 continue -c -c Mext non-comment line has nv clef names -c -6 call getbuf(lineq) - if (lineq(1:1) .eq. '%') go to 6 - iv = 0 - nvsofar = 0 - do 1 jinst = 1 , noinst - nvsofar = nvsofar+nsperi(jinst) - do 10 ivi = 1 , nsperi(jinst) - iv = iv+1 - clefq(iv) = lineq(iv:iv) - if (iv .eq. nvsofar) then - sepsymq(iv) = '&' - else - sepsymq(iv) = '|' - end if -10 continue -1 continue -c -c Mext non-comment line has path name -c -8 call getbuf(pathnameq) - if (pathnameq(1:1) .eq. '%') go to 8 - lpath = index(pathnameq,' ')-1 - return - end - function getsquez(n,ntot,space,tnote,to) - real*4 tnote(600),to(600) - common /comtol/ tol -c -c Get the squez factor by checking space against tgovern=minimum duration -c of all notes sounding at time of n-th note in the list. -c The starting time of base increment is to(n) and ending time is to(n)+space -c Sounding notes are those that start at or before to(n) .and. end at or -c after tend=to(n)+space -c Since notes are ordered by increasing start times, as soon as we find one -c that starts too late, we are done checking. -c - tgovern = 1000. - tend = to(n)+space - do 1 in = 1 , ntot -c -c Since to() is ordered by start times, exit loop after first note that -c starts later than note of interest. -c - - if (to(in) .gt. to(n)+tol) go to 2 - if (to(in)+tnote(in) .gt. tend-tol) then -c -c If here, this note overlaps and must be tested. -c - tgovern = min(tgovern,tnote(in)) - end if -1 continue -2 continue - getsquez = space/tgovern - return - end - subroutine getx(lineq,iccount,irest,shifton,wheadpt,iornq1,ivx, - * irest1,itsofar,ntup,itup,nnodur,dotq,ndoub) - parameter(nm=24) -c -c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. -c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. -c Since during getnote phase time is integer itsofar, which is not updated -c during xtups, we use itup and ntup to get actual time. On entry, ntup=0 if -c not in xtup. -c - common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) - logical shifton,colon,ess,number - character*128 lineq - character*1 charq,durq,dotq - colon = .false. - ess = .false. - number = .false. - nextbl = iccount+index(lineq(iccount:128),' ')-1 - if (index(lineq(iccount:nextbl),'P') .gt. 0) then -c -c "Parts only", ignore entire symbol -c - iccount = nextbl - return - end if -1 call getchar(lineq,iccount,charq) - if (charq.eq.'B') then -c -c "Both parts and score," ignore character -c - go to 1 - else if (charq .eq. ':') then - colon = .true. - go to 1 - else if (charq .eq. 'S') then - ess = .true. - go to 1 - else if (index('+-.0123456789',charq) .gt. 0) then - number = .true. - if (charq.eq.'-') iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - if (charq .eq. '-') fnum = -fnum - if (durq .ne. 'p') then - fnum = fnum*wheadpt - iccount = iccount-1 - end if - go to 1 - end if -c -c charq must be blank, so done parsing -c - if (.not.ess .and. .not.colon) then -c -c Ordinary hardspace. Goes before next note. -c (Later, at "|" or "/", check for presence and switch to udoff if there!) -c - nudsp = nudsp+1 - iornq1 = ibset(iornq1,26) - udsp(nudsp) = fnum - tudsp(nudsp) = itsofar - if (ntup .gt. 0) tudsp(nudsp) = tudsp(nudsp) -c * +float(itup-1)/ntup*ifnodur(nnodur,dotq) - * +float(itup-1+ndoub)/ntup*ifnodur(nnodur,dotq) - else if (.not.number) then -c -c Must be "X:" End a group offset. -c - irest = ibset(irest,17) - shifton = .false. - return - else -c -c Only other possibility is start offset, "S" for single, ':' for multiple -c - nudoff(ivx) = nudoff(ivx)+1 - udoff(ivx,nudoff(ivx)) = fnum - if (ess) then - irest1 = ibset(irest1,15) - else - irest1 = ibset(irest1,16) - shifton = .true. - end if - end if - return - end - function i1fnodur(idur,dotq) - character*1 dotq - if (idur .eq. 6) then - i1fnodur=1 - else if (idur .eq. 3) then - i1fnodur=2 - else if (idur .eq. 1) then - i1fnodur=4 - else if (idur .eq. 8) then - i1fnodur=8 - else if (idur .eq. 4) then - i1fnodur=16 - else if (idur .eq. 2) then - i1fnodur=32 - else if (idur .eq. 0) then - i1fnodur=64 - else if (idur .eq. 16) then -c -c Only used for denominator of time signatures, not for notes -c - i1fnodur=4 - else if (idur .eq. 9) then - i1fnodur = 128 - else - print* - print*,'You entered an invalid note-length value:',idur - call stop1() - end if - if (dotq .eq. 'd') i1fnodur = i1fnodur*3/2 - return - end -c integer*4 function longi(ishort) -c integer*2 ishort -c longi = ishort -c return -c end - function iashft(nacc) - integer*4 ias(6) - data ias /-1,1,0,0,-2,2/ - iashft = ias(nacc) - return - end - function ifnodur(idur,dotq) - character*1 dotq - if (idur .eq. 6) then - ifnodur=1 - else if (idur .eq. 3)then - ifnodur=2 - else if(idur .eq. 1) then - ifnodur=4 - else if(idur .eq. 8) then - ifnodur=8 - else if(idur .eq. 4) then - ifnodur=16 - else if(idur .eq. 2) then - ifnodur=32 - else if(idur .eq. 0) then - ifnodur=64 - else if(idur .eq. 9) then - ifnodur=128 - else if (idur .eq. 16) then -c -c Only used for denominator of time signatures, not for notes -c - ifnodur=4 - else - print*,'You entered an invalid note value' - stop - end if - if (dotq .eq. 'd') ifnodur = ifnodur*3/2 - return - end - function ifnolev(noq,oct,ntrans) - character*1 noq - integer oct - ifnolev = 7*oct+mod(ichar(noq)-92,7)+1+ntrans - return - end -c subroutine report(nsdat,isdat1,isdat2) -c integer*4 isdat1(202),isdat2(202) -c write(*,'(a)') -c * ' isd on? iv kv ip id ud1 ud2 ndx ivo iho lev crd lhd rhd' -c do 1 isdat = 1 , nsdat -c isdata = isdat1(isdat) -c ionoff = igetbits(isdata,1,11) -cc iv = iand(7,isdata) -c iv = igetbits(isdata,5,13) -c kv = igetbits(isdata,1,12)+1 -c ip = igetbits(isdata,8,3) -c idcode = igetbits(isdata,7,19) -c iud1 = igetbits(isdata,1,26) -c iud2 = igetbits(isdata,1,27) -c ndxslur = igetbits(isdata,4,28) -c isdatb = isdat2(isdat) -c ivo = igetbits(isdatb,6,6)-32 -c iho = igetbits(isdatb,7,12)-64 -c lev = igetbits(isdatb,7,19) -c icrd = igetbits(isdatb,1,0) -c lhd = igetbits(isdatb,1,1) -c irhd = igetbits(isdatb,7,2) -c write(*,'(17i4)')isdat,ionoff,iv,kv,ip,idcode,iud1,iud2,ndxslur, -c * ivo,iho,lev,icrd,lhd,irhd -c1 continue -c print* -c return -c end - function igetbits(isdata,iwidbit,ishift) -c -c Extracts integer given by iwidbit bits of isdata, shifted by ishift, and -c then added to ioff -c - igetbits = iand(2**iwidbit-1,ishft(isdata,-ishift)) - return - end - function igetvarlen(mmidi,icm,imidi,nbytes) -c -c Gets variable-length integer starting in mmidi at imidi+1. Returns nbytes. -c - parameter (nm=24,mv=24576) - integer*2 mmidi(0:nm,mv) - igetvarlen = 0 - do 1 nbytes = 1 , 4 - igetvarlen = 128*igetvarlen - * +iand(127,mmidi(icm,imidi+nbytes)) -c * +iand(127,longi(mmidi(icm,imidi+nbytes))) - if (.not.btest(mmidi(icm,imidi+nbytes),7)) return -c if (.not.btest(longi(mmidi(icm,imidi+nbytes)),7)) return -1 continue - print*,'Messup in igetvarlen' - call stop1() - end - logical function isdotted(nodur,ivx,ip) - parameter (nm=24) -c -c Function returns true if note is dotted or double-dotted. -c Return false for any xtuplet. -c - common /comtol/ tol - integer*4 nodur(nm,200) - if (nodur(ivx,ip) .eq. 0) then - isdotted = .false. - return - else if (ip .gt. 1) then - if (nodur(ivx,ip-1) .eq. 0) then - isdotted = .false. - return - end if - end if -c -c Ruled out all xtups, so is dotted or double-dotted if not a power of 2. -c - isdotted = - * mod(alog(float(nodur(ivx,ip)))/.69314718+.5*tol,1.) .gt. tol - return - end - function isetvarlen(idur,nbytes) - isetvarlen = 0 - itemp = idur - do 1 nbytes = 1 , 4 - isetvarlen = isetvarlen + iand(itemp,127)*256**(nbytes-1) - itemp = ishft(itemp,-7) - if (itemp .gt. 0) then - isetvarlen = isetvarlen+2**(8*nbytes+7) - else - return - end if -1 continue - print*,'Problem in function isetvarlen' - call stop1() - end - subroutine istring(i,string,len) -c -c Returns string with integer only if length is 1, otherwise enclosed in -c brackets. -c - character*(*) string - if (i .ne. 0) then - len = alog10(abs(i)*1.0001)+1 - if (i .lt. 0) len = len+1 - else - string = '0' - len = 1 - return - end if - if (len .eq. 1) then - string = char(48+i) - else - string = '{' - write(string(2:1+len),'(i'//char(48+len)//')')i - string = string(1:len+1)//'}' - len = len+2 - end if - return - end - function lenstr(string,n) - character*(*) string - do 1 lenstr = n , 1 , -1 - if (string(lenstr:lenstr) .ne. ' ') return -1 continue - lenstr = 0 - return - end - function levrn(nolev,irest,iud,ncm,mult) -c -c Used for placing numbers in xtups. Returns note level if not a rest, -c else level of top or bottom of rest symbol opposite beam. iud=-1 for upstm. -c - logical btest - if (.not.btest(irest,0)) then - levrn = nolev - else -c -c Restlevel is -4, 0, 2 or 100+offset. First get offset from 1-voice default. -c - if (mult .gt. 0) then - if (mult .eq. 2) then - ioff = -1+2*iud - else if (mult .ne. 4) then - ioff = iud*mult - else - ioff = 1+4*iud - end if - else -c -c May need to futz with this later for non-beamed xtups (quarter, half rests) -c - ioff = iud*2 - end if - levrn = mod(nolev+20,100)-20+ncm+ioff - endif - return - end - function lfmt1(x) -c -c Computes total length of an "f" format with one decimal place. -c First round to nearest 0.1 -c - if (abs(x) .lt. .001) then - lfmt1 = 2 - else - y = sign(.1*int(10*abs(x)+.5),x) - lfmt1 = int(log10(1000*abs(y)+.001)) - if (y .lt. 0) lfmt1 = lfmt1+1 - end if - return - end - subroutine LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat, - * ispstie,sepsymq) - parameter (nm=24) - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - common /comoct/ noctup - integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) - logical fontslur,WrotePsslurDefaults,btest,upslur,ispstie,tie - character*1 udq,chax,sepsymq(nm) - character*8 noteq - character*128 notexq -c -c This is called twice from pmxb after having input an entire block, before -c making a bar that starts a new system. So nsdat reflects all slur starts -c and stops in new block, while listslur, which is only set when bars are -c made, reflects only open slurs from the old block. So we must check -c listslur to find open ties, not all nsdat. -c First of two calls (ispstie=.false. on entry) terminates tie at end of line. -c Second (ispstie=.true. on entry) restarts tie at start of new line. Only -c need data from original tie-start for both of these. Tie/slur data from -c closing of full tie are not used except for shape alterations. -c -c do 1 ndx = 0 , 11 - do 1 ndx = 0 , 23 - if (btest(listslur,ndx)) then -c -c Slur or tie with index ndx is open. Find the one with right ndxb, see if tie -c - do 2 isdat = 1 , nsdat -c if (igetbits(isdat1(isdat),4,28) .ne. ndx) go to 2 ! Wrong index - if (igetbits(isdat1(isdat),4,28) - * +16*igetbits(isdat1(isdat),1,18) .ne. ndx) go to 2 ! Wrong index - if (.not.btest(isdat1(isdat),11)) go to 2 ! Bypass if stop - if (btest(isdat2(isdat),3)) go to 3 ! "st" - idcode = igetbits(isdat1(isdat),7,19) - if (idcode.eq.1) go to 3 ! "t" - tie = .false. - go to 5 -2 continue - end if - go to 1 -3 continue - tie = .true. -5 continue -c -c A slur or tie is open, with index ndx -c - iv = igetbits(isdat1(isdat),5,13) - kv = igetbits(isdat1(isdat),1,12)+1 - udq = 'd' - if (btest(isdat1(isdat),27)) udq='u' - notexq = chax(92)//'znotes' - lnote = 7 - do 4 iiv = 1 , iv-1 - notexq = notexq(1:lnote)//sepsymq(iiv) - lnote = lnote+1 -4 continue - if (kv .eq. 2) then - notexq = notexq(1:lnote)//chax(92)//'nextvoice' - lnote = lnote+10 - end if -c -c Compute horiz and vert offsets -c -c nolev = igetbits(isdat2(isdat),7,19) - islhgt = igetbits(isdat3(isdat),8,14) - ilb12 = 0 - if (ispstie) ilb12 = 1 - ivoff = igetbits(isdat4(isdat),6,ilb12*16)-32 - if (ivoff .eq. -32) ivoff = 0 -C nolev = nolev+ivoff - islhgt = islhgt+ivoff - ihoff = (igetbits(isdat4(isdat),7,ilb12*16+6)-64) ! This is 10X hoff - if (ihoff .eq. -64) ihoff = 0 -c -c Add starting stuff for command -c - if (.not.ispstie) then ! End 1st segment - notexq = notexq(1:lnote)//chax(92)//'roffset{' - lnote = lnote+9 -c hoff = ihoff*.1-.5 -c hoff = ihoff*.1-.8 - hoff = ihoff*.1-.4 - if (hoff .lt. 0) then - hoff = -hoff - notexq = notexq(1:lnote)//'-' - lnote = lnote+1 - end if - call writflot(hoff,notexq,lnote) - notexq = notexq(1:lnote)//'}{' - lnote = lnote+2 - else - notexq = notexq(1:lnote)//chax(92)//'off{-' - * //chax(92)//'afterruleskip}' - lnote = lnote+21 -c -c 091025 add dotting for 2nd segment if needed -c - if (btest(isdat2(isdat),4)) then - notexq = chax(92)//'dotted'//notexq(1:lnote) - lnote = lnote+7 - end if - end if - if (ispstie .and. tie) then - notexq = notexq(1:lnote)//chax(92)//'tieforis'//udq - lnote = lnote+10 - end if - if (btest(isdat3(isdat),0)) then -c -c Curvature tweak on termination of 1st seg -c - imid = igetbits(isdat3(isdat),6,2)-32 -c -c Invoke macro (from pmx.tex) that redefines \tslur as r'qd. mapping: -c Abs(imid) Postscript slur type -c 1 f -c 4 h -c 5 H -c 6 HH -c - notexq = notexq(1:lnote)//chax(92)//'psforts'//chax(48+imid) - lnote = lnote+9 -c -c Zero out the flag in case there's a different curv on term of 2nd, -c - isdat3(isdat) = ibclr(isdat3(isdat),0) - end if -c -c Add the command name -c - if (ispstie) then - notexq = notexq(1:lnote)//chax(92)//'is'//udq - lnote = lnote+4 - else if (tie) then - notexq = notexq(1:lnote)//chax(92)//'ttie' - lnote = lnote+5 - else - notexq = notexq(1:lnote)//chax(92)//'tslur' - lnote = lnote+6 - end if -c -c Add index -c -c if (11-ndx .lt. 10) then -c notexq = notexq(1:lnote)//chax(59-ndx) -c lnote = lnote+1 -c else -c notexq = notexq(1:lnote)//'{1'//chax(49-ndx)//'}' -c lnote = lnote+4 -c end if - if (23-ndx .lt. 10) then - notexq = notexq(1:lnote)//chax(71-ndx) - lnote = lnote+1 - else if (23-ndx .lt. 20) then - notexq = notexq(1:lnote)//'{1'//chax(61-ndx)//'}' - lnote = lnote+4 - else - notexq = notexq(1:lnote)//'{2'//chax(51-ndx)//'}' - lnote = lnote+4 - end if - if (ispstie .or. .not.tie) then -c -c Add note name for slur height -c - noctup = 0 - ncm = igetbits(isdat3(isdat),8,22) - if (ncm .eq. 23) noctup = -2 -c call notefq(noteq,lnoten,nolev,ncm) - call notefq(noteq,lnoten,islhgt,ncm) - notexq = notexq(1:lnote)//'{'//noteq(1:lnoten)//'}' - lnote = lnote+1+lnoten+1 - end if - if (ispstie) then -c -c Horizontal shift start of new thing -c - notexq = notexq(1:lnote)//'{' - lnote = lnote+1 -c ihoff = ihoff-13 - if (tie) then - ihoff = ihoff-12 - else - ihoff = ihoff-7 - end if - if (ihoff .lt. 0) then - ihoff = -ihoff - notexq = notexq(1:lnote)//'-' - lnote = lnote+1 - end if - call writflot(ihoff*.1,notexq,lnote) - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - end if -c -c Add closing stuff -c - if (ispstie) then - notexq = notexq(1:lnote)//chax(92)//'off{' - * //chax(92)//'afterruleskip}' - lnote = lnote+20 - else - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - end if - notexq = notexq(1:lnote)//chax(92)//'en%' - lnote = lnote+4 - write(11,'(a)')notexq(1:lnote) -1 continue - ispstie = .not.ispstie - return - end - subroutine littex(islur,nnl,iv,topmods,lineq,iccount) - parameter (nm=24) - common /comlast/ islast,usevshrink - logical islast,usevshrink - integer islur(nm,200) - logical topmods - common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, - * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, - * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, - * graspace(37), - * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), - * naccg(74),voltxtq(6),litq(83) - logical upg,slurg,slashg,merge - character*128 lineq,litq - character*20 voltxtq - character*1 durq,chax - merge = .false. - if (nlit .gt. 0) then - merge = iv.eq.ivlit(nlit) .and. nnl.eq.iplit(nlit) - end if - nlit = nlit+1 - ivlit(nlit) = iv - iplit(nlit) = nnl - itype = 1 -17 call getchar(lineq,iccount,durq) - if (durq .eq. chax(92)) then - itype=itype+1 - go to 17 - end if - litq(nlit) = chax(92)//durq - lenlit(nlit) = 2 -18 call getchar(lineq,iccount,durq) - if (durq.eq.chax(92)) then - call getchar(lineq,iccount,durq) - if (durq .ne. ' ') then -c -c Starting a new tex command within the string -c - litq(nlit) = litq(nlit)(1:lenlit(nlit))//chax(92)//durq - lenlit(nlit) = lenlit(nlit)+2 - go to 18 - end if - else - litq(nlit) = litq(nlit)(1:lenlit(nlit))//durq - lenlit(nlit) = lenlit(nlit)+1 - go to 18 - end if -c -c If here, just read backslash-blank so string is done -c - if (itype .eq. 1) then - islur(iv,nnl) = ibset(islur(iv,nnl),16) - if (merge) then -c -c There are 2 separate strings on the same note, so merge them. -c - nlit = nlit-1 - litq(nlit) = litq(nlit)(1:lenlit(nlit)) - * //litq(nlit+1)(1:lenlit(nlit+1)) - lenlit(nlit) = lenlit(nlit)+lenlit(nlit+1) - if (lenlit(nlit) .gt. 128) then - print* - print*, - * 'Merged type-1 TeX strings longer than 128 characters' - write(15,'(/,a)') - * 'Merged type-1 TeX strings longer than 128 characters' - call stop1() - end if - end if - else - if (itype .eq. 3) then -c -c Write the string NOW -c - if (islast) - * write(11,'(a)')litq(nlit)(1:lenlit(nlit))//'%' - else -c -c Must go at top -c - if (.not.topmods) then - topmods = .true. - open(16,status='SCRATCH') - end if -c -c Must write '%' here rather than later, in case string ends with blank. -c - write(16,'(a)')litq(nlit)(1:lenlit(nlit))//'%' - end if - nlit = nlit-1 - end if - return - end - function llen(strq,n) - character*129 strq - do 1 llen = n , 0 , -1 - if (strq(llen:llen) .ne. ' ') return -1 continue - end - function log2(n) -c -c 5/25/08 Modify to allow more slurs -c -c log2 = alog(1.*n)/0.6931472+.0001 -c log2 = dlog(1.d0*n)/0.693147181d0+.00000001d0 - log2 = dlog(1.d0*n)/0.693147181d0+.00000002d0 - return - end - subroutine logbeam(numnew,nip1,nip2) - parameter (nm=24) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, - * tautofb,autofbon,t1autofb - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - character*1 ulq,sepsymq,sq,ulfq,ulfbq - logical beamon,firstgulp,figbass,figchk,isfig,isxtup,btest, - * autofbon - ibm1(ivx,numnew) = nip1 - ibm2(ivx,numnew) = nip2 - numnow = numnew - if (numnew .gt. 1) then -c -c If it starts before any others, must put it in order -c - do 11 ib = numnew-1 , 1 , -1 - if (ibm1(ivx,ib) .lt. nip1) go to 12 - ibm1(ivx,ib+1) = ibm1(ivx,ib) - ibm2(ivx,ib+1) = ibm2(ivx,ib) - ulq(ivx,ib+1) = ulq(ivx,ib) - ibm1(ivx,ib) = nip1 - ibm2(ivx,ib) = nip2 - numnow = ib -11 continue -12 continue - end if - sum = 0. -c -c Beam has non-xtup within -c - nrests = 0 - isxtup = .false. - do 9 iip = nip1 , nip2 - if (btest(islur(ivx,nip1),21)) then -c -c Forced multiplicity -c -c mult(ivx,iip) = igetbits(islur(ivx,nip1),3,22) - call setbits(mult(ivx,iip),4,0, - * igetbits(islur(ivx,nip1),3,22)+8) - else if (.not.isxtup) then - if (nodur(ivx,iip) .gt. 0) then -c mult(ivx,iip) = 4-log2(nodur(ivx,iip)) - call setbits(mult(ivx,iip),4,0,4-log2(nodur(ivx,iip))+8) - else -c -c Start xtup within forced beam -c - isxtup = .true. - iip1 = iip - end if - else if (isxtup .and. nodur(ivx,iip).gt.0) then -c -c End of xtup within forced beam. Must count doubled notes -c - ndoub = 0 - do 1 iiip = iip1 , iip - if (btest(nacc(ivx,iiip),18)) ndoub = ndoub+1 -1 continue - multx = int(10.5+2.929+(0.952*alog(1.+iip-iip1+ndoub)- - * alog(nodur(ivx,iip)/2.))/0.69315)-10 - do 74 iiip = iip1 , iip -c mult(ivx,iiip) = multx - call setbits(mult(ivx,iiip),4,0,multx+8) -c -c Note the following still works after making mult only the 1st 4 bits. -c - if (btest(nacc(ivx,iiip),18)) - * mult(ivx,iiip) = mult(ivx,iiip)-1 - if (btest(nacc(ivx,iiip),19)) then - mult(ivx,iiip) = mult(ivx,iiip)+1 - else if (iiip .gt. 1) then - if (btest(nacc(ivx,iiip-1),19)) - * mult(ivx,iiip) = mult(ivx,iiip)+1 - end if -74 continue - isxtup = .false. - end if - if (btest(irest(ivx,iip),0)) then - nrests = nrests+1 - else - sum = sum+nolev(ivx,iip) - end if -9 continue -c -c Set beam up-down-ness -c - if (ifb.gt.0 .and. ulfbq(ivx,max(1,ifb)).ne.'x') then - if (ulfbq(ivx,ifb) .eq. 'f') then -c -c Get default, then trade "l" and "u" -c - ulq(ivx,numnow) = char(225-ichar( - * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1)))) - else - ulq(ivx,ifb) = ulfbq(ivx,ifb) - end if -c -c This probably works only because forced beams are done first, so they -c don't have to be re-sorted within each voice. ???? -c - else if (nvmx(iv) .eq. 2) then -c -c Multi-voice per staff -c - if (ivx .le. nv) then - ulq(ivx,numnow) = 'l' - else - ulq(ivx,numnow) = 'u' - end if - else -c -c Defaults -c - ulq(ivx,numnow) = - * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1)) - end if - return - end - subroutine m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) -c -c This is called when (a) macro recording is just starting and -c (b) at the start of a new line, if recording is on -c - parameter (maxblks=4000) - character*128 lineq,lnholdq - common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac - common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), - * ic1mac(20),ilmac,iplmac - logical mrecord,mplay,endmac - character*65536 bufq - integer*2 lbuf(maxblks) - common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq - lbuf(1) = lbuf(1) - if (.not.mrecord) then -c -c Starting the macro -c - ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount - il1mac(macnum) = ilbuf-1 - ic1mac(macnum) = iccount - mrecord = .true. - end if - if (iccount .lt. 128) then - ndxm = index(lineq(iccount+1:128),'M') - if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M', - * 128-iccount) - if (ndxm .gt. 0) then -c -c This line ends the macro. -c - if (lineq(iccount+ndxm+1:iccount+ndxm+1) .ne. ' ') then - call errmsg(lineq,iccount+ndxm+1,ibarcnt-ibaroff+nbars+1, - * 'Improper macro termination!') - call stop1() - end if - ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm - il2mac(macnum) = ilbuf-1 - mrecord = .false. - end if - end if - return - end - subroutine make1bar(ibmrep,tglp1,tstart,cwrest,squez, - * istop,numbms,istart) - parameter (nm=24,mv=24576) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - common /comipl2/ ipl2(nm,200) - character*10 figq - character*1 ulq,sepsymq,sq - logical beamon,firstgulp,figbass,figchk,isfig,bar1syst - common /comeskz2/ eskz2(nm,200) - common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), - * fullsize(nm),ivxfig2 - common /combeam/ ibmtyp - common /comask/ bar1syst,fixednew,scaldold, - * wheadpt,fbar,poenom - common /comas1/ naskb,task(40),wask(40),elask(40) - common /comas2/ nasksys,wasksys(800),elasksys(800) - common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt - common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, - * tautofb,autofbon,t1autofb - common /comsln/ is1n1,is2n1,irzbnd,isnx - common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, - * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, - * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, - * graspace(37), - * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), - * naccg(74),voltxtq(6),litq(83) - logical upg,slurg,slashg,autofbon - character*128 litq - common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), - * ndotmv(nm),updot(nm,20),rtdot(nm,20) - integer cnn(nm),istart(80),istop(80),nxtnow(nm),ifbnow(nm), - * numbms(nm),mapfb(16) - real*4 xit(nm),t1xtup(20),tstart(80),squez(80) - character*1 ulfbq - character*79 inameq - character*20 voltxtq - common /comoct/ noctup - character*80 headrq,lowerq - logical cwrferm - common /comcwrf/ cwrferm(nm) - common /comnsp/ space(80),nb,prevtn(nm), - * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) - logical lower,cwrest(nm),vxtup,flgndb,btest,upslur, - * infbmx(nm),lowdot,inxtup(nm),drawbm - common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), - * mtupv(nm,9),nxtinbm(nm), - * islope(nm),xelsk(24),eloff(nm,9), - * nssb(nm),issb(nm),lev1ssb(nm,20) - common /comdraw/ drawbm(nm) - common /comstart/ facmtr - common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, - * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, - * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, - * rtshfac -c -c Above are factors for grace note, clef spacing. (fraction of wheadpt) -c In 1.04, moved to block data subprogram -c - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, - * isig,lastisig,fracindent,widthpt,height,idsig, - * lnam(nm),inameq(nm) - common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) - common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), - * xinsnow,lowdot - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - common /comtol/ tol - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur, - * WrotePsslurDefaults - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - common /comntot/ ntot - if (ismidi) then -c -c Initialize for this bar the accidental counter for the midi file. -c naccim(icm) = # of accidentals from earlier in the bar -c - do 45 iv = 1 , nv - do 45 kv = 1 , nvmx(iv) - naccim(midchan(iv,kv)) = 0 -45 continue - end if -c -c Time from start of gulp to end of bar, used with forced beams -c - tglp2 = lenb0+ibar*lenb1 - if (lenb0 .gt. 0) tglp2 = tglp2-lenb1 - tglp1 = tglp2-lenbar -c -c infbmx will only be true if in xtup that is NOT in explicit forced beam. -c - do 1 iv = 1 , nv - do 1 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - cwrest(ivx) = .false. - infbmx(ivx) = .false. - inxtup(ivx) = .false. - if (ibar .gt. 1) then - nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1) - else - nn(ivx) = nib(ivx,ibar) - end if -1 continue -c -c initialize list note counter, time(iv), curr. note(iv). The loop to 4 -c ONLY initializes each voice. -c - in = 1 - nxtup = 0 - narp = 0 - do 4 iv = 1 , nv - do 4 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - cwrferm(ivx) = .false. - cnn(ivx) = 1 - ivxo(in) = ivx - ipo(in) = cnn(ivx) - tnote(in) = fnote(nodur,ivx,1,nacc) - to(in) = 0. - xit(ivx) = tnote(in) -c -c Note that xit(ivx) is to END of note in voice, but it1xtup is start time. -c - if (nodur(ivx,ipo(in)) .eq. 0) then -c -c First note of xtuplet at start of bar in voice ivx. -c - nxtup = nxtup+1 - nxtnow(ivx) = nxtup - inxtup(ivx) = .true. - t1xtup(nxtup) = 0. -c -c Xtup at start of bar. If no explicit forced beam, start one, set -c signal infbmx, and save number ifbnow for use at termination. -c - if (nfb(ivx) .gt. 0) then - do 60 ifb = 1 , nfb(ivx) - if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then -c -c No explicit fb here; so exit loop and insert one. -c - go to 61 - else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and. - * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then -c -c IS explicit fb here; must NOT insert one -c - go to 62 - end if -60 continue - end if -61 continue -c -c If here, xtup isn't in explicit fb, so must insert one -c - infbmx(ivx) = .true. - call addfb(nfb,ivx,t1xtup(nxtup)+ - * tglp1,t1fb,t2fb,ulfbq,ifbadd) - ifbnow(ivx) = ifbadd - end if -62 continue - if (abs(xit(ivx)-lenbar) .lt. tol) xit(ivx) = 1000. - in = in+1 -4 continue -c -c Build the list: This is a manual loop starting at 5 -c -5 continue -c -c Determine which voice comes next from end of notes done so far. -c tmin is the earliest ending time of notes done so far -c - tmin = 1000. - do 6 iiv = 1 , nv - do 6 kv = 1 , nvmx(iiv) - iivx = ivmx(iiv,kv) - tminn = min(tmin,xit(iivx)) - if(tminn .lt. tmin-tol) then - tmin = tminn - ivx = iivx - end if -6 continue - if (abs(tmin-1000.) .lt. tol) go to 7 - ivxo(in) = ivx - cnn(ivx) = cnn(ivx)+1 - ipo(in) = cnn(ivx) - to(in) = tmin -c -c Check if this voice is done -c - tnote(in) = fnote(nodur,ivx,cnn(ivx),nacc) - if (cnn(ivx) .eq. nn(ivx)) then - xit(ivx) = 1000. - else - xit(ivx) = xit(ivx)+tnote(in) - end if -c -c Flag xtups -c - if (nodur(ivx,cnn(ivx)) .eq. 0) then - if (.not.inxtup(ivx)) then -c -c First note of xtup, not at start of bar. -c - nxtup = nxtup+1 - nxtnow(ivx) = nxtup - inxtup(ivx) = .true. - t1xtup(nxtup) = xit(ivx)-tnote(in) -c -c (Note: can't be on last note in voice, so xit(ivx) <> 1000) -c Put xtuplet in a forced beam if not already in forced beam -c - if (nfb(ivx) .gt. 0) then - do 70 ifb = 1 , nfb(ivx) - if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then -c -c NO explicit bm; put one in -c - go to 71 - else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and. - * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then -c -c IS explicit bm. Don't put one -c - go to 72 - end if -70 continue - end if -71 continue -c -c If here, no explicit bm, so put one in -c - infbmx(ivx) = .true. - call addfb(nfb,ivx,t1xtup(nxtup)+tglp1, - * t1fb,t2fb,ulfbq,ifbadd) - ifbnow(ivx) = ifbadd - end if -72 continue - else if (inxtup(ivx)) then -c -c This test is sufficient because already know nodur>0 -c - inxtup(ivx) = .false. - if (infbmx(ivx)) then -c -c Xtup is in auto-forced beam, so end it -c - t2fb(ivx,ifbnow(ivx)) = - * t1xtup(nxtnow(ivx))+nodur(ivx,cnn(ivx))+tglp1 - infbmx(ivx) = .false. - end if - end if - if (btest(irest(ivxo(in),ipo(in)),24) .or. - * btest(irest(ivxo(in),ipo(in)),30)) then -c -c For staff jumped beam, flag the first note (lowest voice) at same time. -c Later will start new notes group here. -c - inj = in - if (ivxo(in) .gt. 1) then - do 40 iin = in-1 , 1 , -1 - if (to(iin)+tol .lt. to(in)) go to 41 - if (abs(to(iin)-to(in)) .lt. tol) then - inj = iin - go to 40 - end if -40 continue - end if -41 continue - irest(ivxo(inj),ipo(inj)) = ibset(irest(ivxo(inj),ipo(inj)),29) - end if - in = in+1 - go to 5 -7 continue - ntot = in-1 - do 8 in = 1 , ntot-1 - tno(in) = to(in+1)-to(in) -8 continue - tno(ntot) = tnote(ntot) -c -c Debug writes -c -c write(*,'()') -c write(*,'(a)')' Greetings from PMXB' -c write(*,'(16i5)')(ivxo(in),in=1,ntot) -c write(*,'(16i5)')(ipo(in),in=1,ntot) -c write(*,'(16f5.1)')(to(in),in=1,ntot) -c write(*,'(16f5.1)')(tno(in),in=1,ntot) -c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) -c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) -c -c Done w/ list. Loop for parsing into note blocks: -c - ib = 1 - istart(1) = 1 - space(1) = 0. - in = 1 -c -c A manual loop to set space(ib) and istop(ib) -c -9 continue - - ivx = ivxo(min(in+1,ntot)) - ip = ipo(min(in+1,ntot)) - isl = islur(ivx,ip) - if (in.eq.ntot .or. ((ivx.eq.1 .and. - * (iand(isl,67109216).gt.0 .or. btest(ipl(1,ip),28) -c * .or. ornq(1,ip).eq.'g')) .or. btest(isl,15) )) then -c Bits 1-13: stmgx+Tupf._) -c 14: Down fermata, was F -c 15: Trill w/o "tr", was U - * .or. btest(iornq(1,ip),4))) .or. btest(isl,15) ) -c -c Checking for start of 2nd part of jumped beam -c - * .or. btest(irest(ivx,ip),29) ) then -c -c Bar end, segno, int. rpt or sig change, clef,end of 1st part of jumped beam; -c flow out of if-loop and into block-wrapup -c -c 10/18/97: Problem with clef alignment. Got isl{15} set on lowest-numbered -c voice, but it wasn't first in the list at the same time. So check if -c prior notes in list have same time -c 5/25/98: This stuff causes trouble with just "c2 Ct c", maybe when clef -c changes on last note in the list? -c - if (btest(isl,15) .and. in.lt.ntot) then - do 50 iin = in , 1 , -1 - if (tno(iin) .gt. tol) then - in = iin - islur(ivx,ip) = ibclr(islur(ivx,ip),15) - islur(ivxo(in+1),ipo(in+1)) = - * ibset(islur(ivxo(in+1),ipo(in+1)),15) - go to 51 - end if -50 continue -51 continue - end if - if (space(ib) .lt. tol) then - space(ib) = tno(in) - squez(ib) = 1. - end if - istop(ib) = in - else if (space(ib) .lt. tol) then -c -c space hasn't been set yet, so tentatively set: -c - space(ib) = tno(in) - if (space(ib) .lt. tol) then - in=in+1 - else - squez(ib) = getsquez(in,ntot,space(ib),tnote,to) - istop(ib) = in - end if - go to 9 - else if (tno(in+1) .lt. tol) then -c -c This is not the last note in the group, so -c - in = in+1 - go to 9 - else if (abs(tno(in+1)-space(ib)) .lt. tol) then - xsquez = getsquez(in+1,ntot,space(ib),tnote,to) - if (abs(xsquez-squez(ib)) .lt. tol) then -c -c Keep spacing the same, update tentative stop point -c - in = in+1 - istop(ib) = in - go to 9 - end if - end if -c -c At this point istart and istop are good, so finalize block -c - tstart(ib) = to(istart(ib)) - if (istop(ib) .eq. ntot) go to 15 - ib = ib+1 - istart(ib) = istop(ib-1)+1 - in = istart(ib) -c -c Set tentative block space and squeeze-factor for upcoming block -c - space(ib) = tno(in) - if (space(ib).gt.tol) - * squez(ib)= getsquez(in,ntot,space(ib),tnote,to) - istop(ib) = in - go to 9 -15 continue - nb = ib -c -c Invert the list of places into ipl(0-7), making it easier to analyze a voice -c - do 13 in = 1 , ntot -c -c ??? This may fix extra \loff's (bit 8 of ipl) in measures with >255 notes. -c -c ipl(ivxo(in),ipo(in)) = ior(ipl(ivxo(in),ipo(in)),in) - ipl2(ivxo(in),ipo(in)) = in -13 continue -c -c Compute elemskips from start of bar to each note in the bar, for beam slopes -c - eskzb = 0. - ib = 1 - do 30 in = 1 , ntot - if (in .eq. istart(ib)) then - deskb = squez(ib)*feon(space(ib)/squez(ib)) - else if (tno(in-1) .gt. tol) then - eskzb = eskzb+deskb - end if - eskz(ivxo(in),ipo(in)) = eskzb - eskz2(ivxo(in),ipo(in)) = eskzb - if (in .eq. istop(ib)) then - eskzb = eskzb+deskb - ib = ib+1 - end if -30 continue -c -c Debug writes -c -c print* -c write(*,'(16f5.1)')(eskz(ivxo(in),ipo(in)),in=1,ntot) -c print*,'PMXB has now got blocks' -c write(*,'(16i5)')(istart(ib),ib=1,nb) -c write(*,'(16i5)')(istop(ib),ib=1,nb) -c write(*,'(16f5.1)')(space(ib),ib=1,nb) -c write(*,'(16f5.1)')(squez(ib),ib=1,nb) -c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) -cc write(*,'(26i3)')(iand(islur(ivxo(in),ipo(in)),30720)/2048, -c * in=1,ntot) -c write(*,'(1x,26a3)')(ornq(ivxo(in),ipo(in)),in=1,ntot) -c -c -c Analyze for beams. -c - do 20 iv = 1 , nv - do 20 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - numbms(ivx) = 0 - mapfb(1) = 0 - mapfb(2) = 0 - mapfb(3) = 0 - mapfb(4) = 0 -c -c First forced beams. -c - if (nfb(ivx) .gt. 0) then -c -c tglp2 is time from start of gulp to end of current bar. -c - nfbbar = 0 - do 80 ifb = 1 , nfb(ivx) - if (t1fb(ivx,ifb).gt.tglp2-tol) go to 81 - nfbbar = nfbbar+1 - numbms(ivx) = numbms(ivx)+1 - numnew = numbms(ivx) -c -c Times from beginning of bar -c - itbb1 = int(t1fb(ivx,ifb)-tglp1+tol) - itbb2 = int(t2fb(ivx,ifb)-tglp1+tol) - do 83 ip = 1 , nn(ivx) - if (int(to(ipl2(ivx,ip))+tol) .eq. itbb1) then - nip1fb = ip - do 84 ip1 = ip , nn(ivx) - inip1 = ipl2(ivx,ip1) - if (abs(to(inip1)+tnote(inip1)-itbb2) .lt. tol) then - nip2fb = ip1 - itbb3 = itbb2-2 - go to 85 - end if -84 continue - end if -83 continue - print* - print*,'Timing problem w/ forced beams' - write(15,'(/a)')'Timing problem w/ forced beams' -85 continue - call logbeam(numnew,nip1fb,nip2fb) -c -c Set up mapfb for forced beam just logged: -c - ib1 = itbb1/2 - ib2 = itbb3/2 - ibrep = lenbar/ibmrep/2 - do 86 irep = 1 , ibmrep - ib1now = max(0,ib1-(irep-1)*ibrep) - ib2now = min(irep*ibrep-1,ib2-(irep-1)*ibrep) - mapnow = 0 - do 87 ib = ib1now , ib2now - mapnow = ibset(mapnow,ib) -87 continue - mapfb(irep) = ior(mapfb(irep),mapnow) -86 continue -c -c Since we are cycling thru forced beams, for those that start with a rest and -c have height & slope adjustments, move adjustments to next note. -c 060924: Copy to ALL later notes in fb, in case there's more than 1 rest at -c start of beam -c - if (btest(irest(ivx,nip1fb),0)) then -c call setbits(ipl(ivx,nip1fb+1),6,11, -c * igetbits(ipl(ivx,nip1fb),6,11)) -c call setbits(ipl(ivx,nip1fb+1),6,17, -c * igetbits(ipl(ivx,nip1fb),6,17)) -c call setbits(islur(ivx,nip1fb+1),2,27, -c * igetbits(islur(ivx,nip1fb),2,27)) - do 88 kp = nip1fb+1 , nip2fb - call setbits(ipl(ivx,kp),6,11, - * igetbits(ipl(ivx,nip1fb),6,11)) - call setbits(ipl(ivx,kp),6,17, - * igetbits(ipl(ivx,nip1fb),6,17)) - call setbits(islur(ivx,kp),2,27, - * igetbits(islur(ivx,nip1fb),2,27)) -88 continue - end if -80 continue -81 continue -c -c Slide down, reduce nfb(ivx). This lets us count up from 1 for each new bar. -c Remember, makeabar is called 1/bar, and it calls findbeam once per voice. -c - if (nfbbar .gt. 0) then - nfb(ivx) = nfb(ivx)-nfbbar - do 82 ifb = 1 , nfb(ivx) - t1fb(ivx,ifb) = t1fb(ivx,ifb+nfbbar) - t2fb(ivx,ifb) = t2fb(ivx,ifb+nfbbar) - ulfbq(ivx,ifb) = ulfbq(ivx,ifb+nfbbar) -82 continue - end if - end if - ifb = 0 -c -c Done with forced beam masks for this bar and voice. Now get normal beams. -c - call findbeam(ibmrep,numbms,mapfb) -20 continue - return - end - subroutine make2bar(ninow,tglp1,tstart,cwrest,squez, - * istop,numbms,istart,clefq) - parameter (nm=24,mv=24576) - common /comlast/ islast,usevshrink - logical islast,usevshrink - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - common /comipl2/ ipl2(nm,200) - character*10 figq - character*1 ulq,sepsymq,sq,chax - logical beamon,firstgulp,figbass,figchk,isfig,bar1syst,isbjmp, - * isbj2 - common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 - common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), - * fullsize(nm),ivxfig2 - common /combeam/ ibmtyp - common /comask/ bar1syst,fixednew,scaldold, - * wheadpt,fbar,poenom - common /comas1/ naskb,task(40),wask(40),elask(40) - common /comas2/ nasksys,wasksys(800),elasksys(800) - common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt - common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, - * tautofb,autofbon,t1autofb - common /comsln/ is1n1,is2n1,irzbnd,isnx - common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, - * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, - * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, - * graspace(37), - * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), - * naccg(74),voltxtq(6),litq(83) - logical upg,slurg,slashg,issig,rpndot,autofbon - character*128 litq - common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), - * ndotmv(nm),updot(nm,20),rtdot(nm,20) - integer istart(80),istop(80),iaskb(nm),numbms(nm), - * nornb(nm),ihornb(nm,24),lcwr(nm),ibmcnt1(nm),ifig(2) - character*1 ulfbq,udqq,clefq(nm),slurudq - character*8 noteq - character*79 cwrq(nm),notexq,inameq - character*20 voltxtq - common /comoct/ noctup - character*80 soutq,headrq,lowerq - common /comnsp/ space(80),nb,prevtn(nm), - * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) - logical bspend,lower,cwrest(nm),vxtup, - * isgrace,isclef,nofirst,iscln,isdot,isflag, - * isacc,isfirst,flgndb,btest,stemup,upslur, - * isgaft,isarp,isrshft,isaccs,iscacc, - * lowdot,flipend,iscwr,isdotted,beamon1(nm) - real*4 ptgr(37),ptclef(nm),ptsndg(nm),eskndg(nm),tstart(80), - * squez(80) - logical cwrferm,drawbm - common /comcwrf/ cwrferm(nm) - common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), - * mtupv(nm,9),nxtinbm(nm), - * islope(nm),xelsk(24),eloff(nm,9), - * nssb(nm),issb(nm),lev1ssb(nm,20) - common /comdraw/ drawbm(nm) - common /comstart/ facmtr - common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, - * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, - * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, - * rtshfac -c -c Factors for grace note, clef spacing. (fraction of wheadpt) -c In 1.04, moved to block data subprogram -c - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, - * isig,lastisig,fracindent,widthpt,height,idsig, - * lnam(nm),inameq(nm) - common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) - common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), - * xinsnow,lowdot - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - common /strtmid/ ihnum3,flipend(nm),ixrest(nm) - common /comtol/ tol - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur - * ,WrotePsslurDefaults - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - logical slmon,dbltie - common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), - * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, - * slmon(0:nm),dbltie - common /comevent/ miditime,lasttime - logical kbdrests - common /comkbdrests/ levbotr(8),levtopr(8),kbdrests - logical secondgrace -c - common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), - * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans - logical EarlyTransOn,LaterInstTrans -c -c -c Set up main ib loop within which a block (notes group) is written -c - do 25 iv = 1 , nv - do 25 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - ibmcnt(ivx) = 1 - ibmcnt1(ivx) = 1 - beamon(ivx) = .false. - beamon1(ivx) = .false. - nornb(ivx) = 0 - iaskb(ivx) = 1 - vxtup(ivx) = .false. - drawbm(ivx) = .true. -25 continue - naskb = 0 - ifig(1) = 1 - ifig(2) = 1 - ixtup = 0 - bspend = .false. - iscwr = .false. - rpndot = .false. - do 16 ib = 1 , nb -c -c Check for segno -c - if (btest(iornq(1,ipo(istart(ib))),4) .and. - * ivxo(istart(ib)).eq.1) then - if (noffseg.le.-10) then - write(noteq(1:5),'(1H{,i3,1H})')noffseg - lnoten = 5 - else if (noffseg.lt.0 .or. noffseg.ge.10) then - write(noteq(1:4),'(1H{,i2,1H})')noffseg - lnoten = 4 - else - write(noteq(1:1),'(i1)')noffseg - lnoten = 1 - end if - notexq = sq//'znotes'//sq//'segnoo'//noteq(1:lnoten)//'9' - lnote = 15+lnoten - do 130 iv = 2 , nv - if (lnote .gt. 60) then - if (islast) write(11,'(a)')notexq(1:lnote)//'%' - notexq = sepsymq(iv-1)//sq//'segnoo' - * //noteq(1:lnoten)//'9' - lnote = lnoten+9 - else - notexq = notexq(1:lnote)//sepsymq(iv-1)//sq//'segnoo' - * //noteq(1:lnoten)//'9' - lnote = lnote+lnoten+9 - end if -130 continue - if (islast) write(11,'(a)')notexq(1:lnote)//sq//'en' - lnote = 0 - end if -c -c Check for new clefs -c - isclef = .false. - if (btest(islur(ivxo(istart(ib)),ipo(istart(ib))),15)) - * then -c -c In preceding line, fl32 gave wrong result for ... .gt.0 !!! -c - do 140 in = istart(ib) , istop(ib) - if (btest(islur(ivxo(in),ipo(in)),11)) then - call wsclef(ivxo(in),ninow,clefq, - * iand(ishft(islur(ivxo(in),ipo(in)),-12),7)) - end if -140 continue - if (islast) write(11,'(a)')sq//'pmxnewclefs' - isclef = .true. - end if -c -c Start a notes group. We're just gonna define every one using pnotes{n}, -c where \def\pnotes#1{\vnotes#1\elemskip} -c - soutq = sq//'pnotes{' - eonsqz = squez(ib)*feon(space(ib)/squez(ib)) - if (eonsqz .gt. 9.995) then - write(soutq(9:12),'(f4.1)')eonsqz - else if (eonsqz .gt. 0.995) then - write(soutq(9:12),'(f4.2)')eonsqz - else if (eonsqz .gt. 0.095) then - soutq = soutq(1:8)//'0.' - write(soutq(11:12),'(i2)')nint(100*eonsqz) - else - soutq = soutq(1:8)//'0.0' - write(soutq(12:12),'(i1)')nint(100*eonsqz) - end if - soutq = soutq(1:12)//'}' - lsout = 13 -c -c Check whole block, flag accidentals etc that are too close, one per *time*. -c Note about bar starts and after rpt's/boublebars: There is an afterruleskip -c (fbar*wheadpt) following, but rpts seem to occupy some of that gap, so -c (dotsfac*wheadpt) is presumed to be filled up. -c - in = istart(ib)-1 - itrpt = -1 - itsig = -1 -c -c Begin big manual loop over notes in this block; ends at 112 -c -111 in = in+1 - if (in .gt. istop(ib)) go to 112 - ip = ipo(in) - ivx = ivxo(in) - if (ivx .le. nv) then - iv = ivx - else - do 128 iv = 1 , nv - if (nvmx(iv) .eq. 2 .and. ivmx(iv,2).eq. ivx) go to 129 -128 continue - print*,'Trouble finding iv!, ivx,nvmx,ivmx:',ivx,nvmx(1),nvmx(2) - print*,ivmx(1,1),ivmx(1,2),ivmx(2,1),ivmx(2,2) - stop - end if -129 continue -c -c Call precrd here so we know how much space to add for accid's in chords -c After calling precrd, icashft>0 means there is a shifted chordal accid (incl. -c main note. -c -c To call precrd, need up-downness, so must track if in beam. -c -c Deal w/ staff-jumping beams later -c if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) -c * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or. -c * btest(nacc(ivx,ip),21)) then -c if (.not.btest(irest(ivx,ip),24)) then - if ((numbms(ivx).gt.0 .and. ibmcnt1(ivx).le.numbms(ivx) - * .and. ibm1(ivx,ibmcnt1(ivx)) .eq. ip)) then - beamon1(ivx)=.true. - end if - icashft = 0 - if (btest(ipl(ivx,ip),10)) then -c -c There is a chord on this note. Need up-down-ness in precrd to auto shift for 2nds. -c - if (beamon1(ivx)) then - call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), - * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt1(ivx)), - * .false.,icashft) - else - call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), - * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip), - * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv), - * .false.,icashft) - end if - end if -c -c Turn beam off? -c - if (beamon1(ivx) .and. ibm2(ivx,ibmcnt1(ivx)).eq.ip) then - beamon1(ivx) = .false. - ibmcnt1(ivx) = ibmcnt1(ivx)+1 - end if -c -c Remember, rpts & internal sigs can only come at start of (internal) block -c - isacc = iand(nacc(ivx,ip),3).gt.0 - * .and. .not.btest(nacc(ivx,ip),17) - * .and. .not.btest(ipl(ivx,ip),10) -c -c i.e., do not set for chord. Now check for "(" as ornament on main note, -c -c!!! Need to do this for chord notes too. Maybe in chkarp? -c - isaccs = isacc .or. btest(iornq(ivx,ip),0) -c -c 5/15/02 Add check for ) ornament of prior note. -c 5/16 Nope...fails when grace intervenes. -c if (ip .gt. 1) then -c isaccs = isaccs .or. btest(iornq(ivx,ip-1),13) -c end if - isarp = btest(iornq(ivx,ip),27) - iscacc = .false. - if (btest(ipl(ivx,ip),10)) then -c -c There is a chord here; check for arpeggios and accidentals. Note accid shifts are -c not of concern here, only whether there's an accid, whick causes iscacc=.true. -c - iscacc = igetbits(nacc(ivx,ip),3,0).gt.0 .and. - * .not.btest(nacc(ivx,ip),17) - call chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp) - end if -c -c When we get motivated, will do spacing for arpeggios here. -c - if (ivx.eq.1 .and. iand(islur(ivx,ip),96).gt.0) - * itrpt = nint(to(in)) - issig = btest(ipl(ivx,ip),28) - if (ivx.eq.1 .and. issig) itsig = nint(to(in)) - isgrace = btest(islur(ivx,ip),4) .and. - * .not.btest(ipl(ivx,ip),29) .and. .not.btest(ipl(ivx,ip),31) - isgaft = .false. - if (ip .gt. 1) then - xnd = tnote(ipl2(ivx,ip-1)) - isgaft = btest(ipl(ivx,ip-1),29) .or. btest(ipl(ivx,ip-1),31) - isgrace = isgrace .or. isgaft - end if - iscln = isclef .and. btest(islur(ivx,ip),11) -c -c Is prev. note non-beamed, up-stemmed, & flagged? Recall if ip>1, have nd -c - isflag = ip.gt.1 .and. xnd.gt.tol .and. xnd.lt.16.-tol - if (isflag) - * isflag = .not.btest(irest(ivx,ip-1),0) - * .and. udqq(nolev(ivx,ip-1), - * ncmid(iv,ip-1),islur(ivx,ip-1),nvmx(iv),ivx,nv).eq.'u' - if (isflag) then - do 116 ibmchk = 1 , numbms(ivx) - if (ip-1 .lt. ibm1(ivx,ibmchk)) then - go to 117 -c -c Add check for non-beamed xtuplets. May be problem with stem direction. -c -c else if (ip-1.le.ibm2(ivx,ibmchk)) then - else if (ip-1.le.ibm2(ivx,ibmchk) .and. - * .not.btest(islur(ivx,ibm1(ivx,ibmchk)),18)) then - isflag = .false. - go to 117 - end if -116 continue - end if -117 continue -c -c If isflag, then won't need to check for dot on prev. note. -c -c 5/16/02 ??? Try using this for ) ornament. -c - isflag = isflag .or. btest(iornq(ivx,ip-1),13) - isdot = ip.gt.1 - if (isdot) isdot = isdotted(nodur,ivx,ip-1) - isrshft = ip .gt. 1 - if (isrshft) isrshft = btest(irest(ivx,ip-1),20) - if (.not.(isaccs.or.isgrace.or.iscln.or.isflag.or.isrshft.or. - * isdot.or.btest(iornq(ivx,ip),26).or. - * btest(irest(ivx,ip),21).or.isarp.or. - * btest(irest(ivx,ip),27).or.iscacc)) go to 111 -c -c Here is an accid,grace,clef,flag,rtshft,dot,udsp,arpeg,left-shift. -c Compute pts, the total occupied space including prior notehead. -c - wheadpt1 = wheadpt*fullsize(iv) - pts = wheadpt1 -c -c Set up for possible cautionary accidental here -c - if (isaccs .or. iscacc) then - if (.not.btest(iornq(ivx,ip),31)) then - taccfac = accfac - else - taccfac = 1.4*accfac - end if - end if - if (isgrace) then - secondgrace = .false. - do 122 ig = 1 , ngrace - if (.not. isgaft) then - if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 123 - else if (ip .gt. 1) then - if (ipg(ig).eq.ip-1 .and. ivg(ig).eq.ivx) go to 123 - end if -122 continue - print*,'Problem finding grace index in makeabar' - stop -123 continue -c -c wgr = distance to backspace (in headwidths), less main acc. -c ptgr = same in pts,+ main acc. Not used for after-grace. Distance to backspace. -c spgr = total space needed (w/o main acc). -c Also, spgr is same for b4 or after, but xb4fac-space will be in diff. place. -c - if (nng(ig) .eq. 1) then - wgr = grafac - if (multg(ig) .eq. 0) wgr = wgr-.4 - else - wgr = nng(ig)*emgfac - do 126 ing = 2 , nng(ig) - if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac -126 continue - end if - if (graspace(ig) .gt. 0.) then -c -c User-defined space before grace -c - wgr = wgr+graspace(ig) - end if - ptgr(ig) = wgr*wheadpt1 - spgr = ptgr(ig)+xb4fac*wheadpt1 -c -c!!! May need to mod for chord accid's -c - if (isaccs .or. iscacc) ptgr(ig) = ptgr(ig) + taccfac*wheadpt1 - if (naccg(ngstrt(ig)) .gt. 0) spgr = spgr+wheadpt1*agc1fac - pts = pts+spgr -c -c Special check for after-grace on ip-1 and normal on ip. Must go back thru -c loop again for the normal grace. -c - if (isgaft .and. ig.lt.ngrace .and. .not.secondgrace) then - if (ipg(ig+1).eq.ip) then - secondgrace = .true. - ig = ig+1 - go to 123 - end if - end if - end if - if (iscln) then - pts = pts+clefac*wheadpt1 -c -c How far to backspace when printing the clef -c - ptclef(ivx) = 0. -c -c!!! May need to mod for chord accid's -c - if (isaccs .or. iscacc) - * ptclef(ivx) = ptclef(ivx)+taccfac*wheadpt1 - if (isgrace) ptclef(ivx) = ptclef(ivx)+spgr - end if - if (isrshft) then - pts = pts+rtshfac*wheadpt1 - else if (isflag) then - pts = pts+flagfac*wheadpt1 - else if (isdot) then - pts = pts+dotfac*wheadpt1 - end if - if (abs(to(in)-itrpt) .lt. tol) then -c -c Repeat, need a little extra space -c - pts = pts+dotsfac*wheadpt1 - end if - if (isarp) then - pts = pts+arpfac*wheadpt1 - end if -c -c Add in padding space -c - pts = pts+xspfac*wheadpt1 -c -c Now done with all items needing space except accidentals, -c accidental shifts, and left-notehead-shifts, and will later -c subtract a notehead if at start of bar. -c -c Get available space in elemskips (esk) -c -c isfirst = ip.eq.1 .or. to(in).eq.itrpt .or. -c * to(in) .eq. itsig - isfirst = ip.eq.1 .or. abs(to(in)-itrpt).lt.tol .or. - * abs(to(in)-itsig).lt.tol - if (isfirst) then -c -c At start of bar or after repeat sign or new signature -c -c if (to(in) .eq. itsig) then - if (abs(to(in)-itsig).lt.tol) then - esk = 0. - else - esk = fbar - end if - else -c -c Not 1st note of bar -c - esk = eskz(ivx,ip)-eskz(ivx,ip-1) - end if - if (isgrace) then -c -c Since graces can be very long, cannot assume no interference if prior -c note uses >1 noteskip. So must get elsk's back to prior note, whether or -c not it used only one noteskip. -c <<But if it was xtup. don't need to call eskb4.>>???? -c -c 10/8/05 Kluge to not zero out esk if in xtup -c - esksav = esk - if ((ip.le.2 .or. nodur(ivx,max(1,ip-2)).gt.0) .and. -c * to(in).ne.itsig) - * abs(to(in)-itsig).gt.tol) - * call eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk) - if (abs(esk) .lt. tol) esk = esksav - end if -c -c Done getting available elemskips. Remove headwidth if first. Must do here -c rather than earlier since check uses isfirst -c - if (isfirst) pts = pts-wheadpt1 -c -c Deal with accidental shifts and left-notehead shifts -c - if (btest(ipl(ivx,ip),10)) then -c -c In a chord -c - ptsl = 0. - if (btest(irest(ivx,ip),27)) ptsl = wheadpt1 - ptsadd = max(ptsl,icashft*.05*wheadpt1) -c -c Note: may have icashft=-20000 (if shftmin=-1000 in crdacc) but that's OK -c - else -c -c Not in a chord -c - ihshft = 0 - if (isaccs) then - ihshft = igetbits(nacc(ivx,ip),7,10) -c if (ihshft .ne. 0) ihshft = max(0,64-ihshft) - if (ihshft .ne. 0) ihshft = max(0,107-ihshft) - end if -c -c Check for left-shifted main note -c - if (btest(ipl(ivx,ip),8)) ihshft = max(20,ihshft) - ptsadd = ihshft*.05*wheadpt1 - end if - pts = pts+ptsadd - if (isgrace) ptgr(ig) = ptgr(ig)+ptsadd - if (iscln) ptclef(ivx) = ptclef(ivx)+ptsadd -c -c Left-shifted, non-chord note before? -c - if (ip .gt. 1) then - if (.not.btest(ipl(ivx,ip-1),10) .and. - * btest(irest(ivx,ip-1),27)) pts = pts-wheadpt1 - end if -c -c Try big accidentals first -c - ptbneed = pts - if (isaccs .or. iscacc) then - ptbneed = ptbneed+wheadpt1*bacfac - end if - if (poenom*esk .gt. ptbneed) then -c -c Set flag for big accidental -c - if (isacc) nacc(ivx,ip) = ibset(nacc(ivx,ip),3) - go to 99 - end if -c -c Cannot use big, so try small -c - ptsneed = pts - if (isaccs .or. iscacc) then - ptsneed = ptsneed+taccfac*wheadpt1 - end if - if (poenom*esk .lt. ptsneed) call addask(to(in),ptsneed, - * esk,fixednew,scaldold,0.,.false.) -99 continue - if (btest(iornq(ivx,ip),26)) then -c -c User-defined space. Warning, "zero" may change value in addask! -c - zero = 0. - call addask(to(in),ptsneed,zero, - * fixednew,scaldold,tglp1,.true.) - end if -c -c End of big manual loop over "in" for accidental checking -c - go to 111 -112 continue -c -c End of ask analysis for this block. -c -c Adjust eskz if there are added spaces. Corrects length of xtup brackets. -c - if (naskb.gt.0) call adjusteskz(ib,squez,istart,istop,poenom) -c -c Check for internal repeat or sig change. -c - if (ib.gt.1 .and. ivxo(istart(ib)).eq.1) then - iirpt = iand(islur(1,ipo(istart(ib))),67109216) - if (iirpt .gt. 0) then -c -c Internal repeat -c - if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%' - if (iirpt .eq. 96) then - if (islast) write(11,'(a)')sq//'leftrightrepeat' - fixednew = fixednew+lrrptfac*wheadpt - else if (btest(iirpt,5)) then - if (islast) write(11,'(a)')sq//'leftrepeat' - fixednew = fixednew+rptfac*wheadpt - else if (btest(iirpt,6)) then - if (islast) write(11,'(a)')sq//'rightrepeat' - fixednew = fixednew+rptfac*wheadpt - else if (btest(iirpt,8)) then - if (islast) write(11,'(a)')sq//'doublebar' - else - print*,'Unexpected mid-bar repeat command R*' - call stop1() - end if - scaldold = scaldold-fbar - end if - if (btest(ipl(1,ipo(istart(ib))),28)) then -c -c Internal signature change. -c - notexq = sq//'generalsignature{' - lnote = 18 - if (isig .lt. 0) then - notexq = notexq(1:lnote)//'-' - lnote = lnote+1 - end if - if (islast) write(11,'(a)')notexq(1:lnote) - * //chax(48+abs(isig))//'}%' - if (islast) write(11,'(a)')sq//'zchangecontext'//sq - * //'addspace{-.5'//sq//'afterruleskip}%' - lnote = 0 - end if - end if - flgndb = .false. -c -c Done with start-of-block stuff. Begin main loop over voices. -c - do 11 iv = 1 , nv - do 11 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - icm = midchan(iv,kv) -c -c A rather klugey way to set flag for figure in this voice -c Must always check figbass before figchk. -c - if (figbass) then - ivf = 0 - if (ivx .eq. 1) then - ivf = 1 - else if (ivx .eq. ivxfig2) then - ivf = 2 - end if - if (ivf.gt.0) figchk(ivf) = nfigs(ivf).gt.0 - end if - if (ivx .gt. 1) then - if (ivx .le. nv) then - call addstr(sepsymq(iv-1),1,soutq,lsout) - else - call addstr(sq//'nextvoice',10,soutq,lsout) - end if - end if - if (ihdht.gt.0 .and. ivx.eq.nv) then -c -c Write header. First adjust height if needed to miss barno. -c - if (bar1syst .and. iline.ne.1) then - ihdht = 15+irzbnd+isnx - end if -c -c Add user-defined vertical shift -c - ihdht = ihdht+ihdvrt - lchead = lenstr(headrq,80) - notexq = sq//'zcharnote{' - write(notexq(12:13),'(i2)')ihdht - notexq = notexq(1:13)//'}{'//sq//'bigfont'//sq//'kern-30pt ' - call addstr(notexq,34,soutq,lsout) - call addstr(headrq(1:lchead)//'}',1+lchead,soutq,lsout) - ihdht = 0 - end if - if (lower .and. ivx.eq.nv) then - lclow = lenstr(lowerq,80) - call addstr(sq//'zcharnote{-6}{'// - * sq//'tempo'//sq//'kern-10pt '// - * lowerq(1:lclow)//'}',33+lclow,soutq,lsout) - lower=.false. - end if - tnow = tstart(ib) - nofirst = .true. -c -c Done setting up voice ivx for start of block ib. Loop over notes in voice. -c - do 10 jn = istart(ib), istop(ib) - if (ivxo(jn) .ne. ivx) go to 10 - ip = ipo(jn) -c -c May have problem with not initializing islhgt, so do it here -c - islhgt = 0 -c - if (nofirst) then - noctup = 0 - if (ncmid(iv,ip) .eq. 23) noctup = -2 - nofirst = .false. - end if -c -c Check for internal floating figure (before last note of group). -c -12 if (figbass) then - if (ivx.eq.1 .or. ivx.eq.ivxfig2) then - ivf = 1 - if (ivx .gt. 1) ivf = 2 - if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.tnow-tol) - * then -c -c Bypassed figure location. Backup, place fig, return. -c - offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib) - call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq, - * lsout) - go to 12 - end if - end if - end if -c -c Put in \sk if needed -c - if (to(jn) .gt. tnow+tol) then - call addstr(sq//'sk',3,soutq,lsout) - tnow = tnow+space(ib) - go to 12 - end if -c -c Check for user-defined shifts -c - if (btest(irest(ivx,ip),15).or.btest(irest(ivx,ip),16)) - * call putshft(ivx,.true.,soutq,lsout) -21 if (iaskb(ivx).le.naskb .and. - * tnow.gt.task(iaskb(ivx))-tol) then - if (task(iaskb(ivx)) .gt. tstart(ib)-tol) then -c -c Insert placeholder for accidental skip -c - call addstr(sq//'ask ',9,soutq,lsout) - nasksys = nasksys+1 - wasksys(nasksys) = wask(iaskb(ivx)) - if (wask(iaskb(ivx)) .gt. 0.) then - elasksys(nasksys) = elask(iaskb(ivx)) - else -c -c This is a signal to permit negative ask's. Should really have elask>=0. -c - elasksys(nasksys) = -elask(iaskb(ivx)) - end if - end if -c -c May have skipped some task's in earlier blocks (due to void voice) -c - iaskb(ivx) = iaskb(ivx)+1 - go to 21 - end if - if (figbass) then - if (ivx.eq.1 .or. ivx.eq.ivxfig2) then - ivf = 1 - if (ivx .gt. 1) ivf = 2 - if (figchk(ivf) .and. - * abs(itfig(ivf,ifig(ivf))-tnow).lt.tol) then -c -c Figure on a note. NB: later special check for late figs. -c - call putfig(ivf,ifig(ivf),0.,figchk(ivf),soutq,lsout) - end if - end if - end if -c -c Check for new clef here. -c - if (isclef .and. btest(islur(ivx,ip),11)) then -c print*,'At clef insertion, ptclef:',ptclef(iv) - if (ptclef(iv) .gt. 0.) then - notexq = sq//'off{-' - if (ptclef(iv) .lt. 9.95) then - write(notexq(7:9),'(f3.1)')ptclef(iv) - lnote = 9 - else - write(notexq(7:10),'(f4.1)')ptclef(iv) - lnote = 10 - end if - notexq = notexq(1:lnote)//'pt}' - lnote = lnote+3 - call addstr(notexq,lnote,soutq,lsout) -c print*,'Just added: ',notexq(1:lnote) - end if - call clefsym(islur(iv,ip),notexq,lnote,nclef) - call addstr(notexq,lnote,soutq,lsout) - if (ptclef(iv) .gt. 0.) then - notexq = sq//'off{' - if (ptclef(iv) .lt. 9.95) then - write(notexq(6:8),'(f3.1)')ptclef(iv) - lnote = 8 - else - write(notexq(6:9),'(f4.1)')ptclef(iv) - lnote = 9 - end if - notexq = notexq(1:lnote)//'pt}' - lnote = lnote+3 - call addstr(notexq,lnote,soutq,lsout) - end if - end if -c -c Checking for literal TeX string BEFORE starting beams!! -c - if (btest(islur(ivx,ip),16)) then - do 124 il = 1 , nlit - if (iplit(il).eq.ip .and. ivlit(il).eq.ivx) go to 125 -124 continue - print*,'Problem finding index for literal string' - call stop1() -125 continue -c -c Write a type 1 tex string. -c - if (lenlit(il) .lt. 71) then -c -c Add normally -c - call addstr(litq(il),lenlit(il),soutq,lsout) - else -c -c Longer than 71. Write souq, Write string, start new soutq. -c - if (islast) write(11,'(a)')soutq(1:lsout)//'%' - if (islast) write(11,'(a)')litq(il)(1:lenlit(il))//'%' - lsout = 0 - end if - end if -c -c Arpeggio on a main (non-chordal) note? -c - if (btest(iornq(ivx,ip),27)) then -c call putarp(tnow,iv,ip,nolev(ivx,ip),ncmid(iv,ip), - call putarp(tnow,ivx,ip,nolev(ivx,ip),ncmid(iv,ip), - * soutq,lsout) - end if -c -c See if a beam starts here -c - if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) - * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or. - * btest(nacc(ivx,ip),21)) then - if (.not.btest(irest(ivx,ip),24)) then -c -c Not a jump start -c - call beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib) -c -c Shift beam start if notehead was shifted -c - if (btest(ipl(ivx,ip),8)) then - call addstr(sq//'loff{',6,soutq,lsout) - else if (btest(ipl(ivx,ip),9)) then - call addstr(sq//'roff{',6,soutq,lsout) - end if - if (lnote .gt. 0) call addstr(notexq,lnote,soutq,lsout) - if (btest(ipl(ivx,ip),8) .or. - * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout) - else -c -c Jump start. Set marker for second part of a jump beam. Note ivbj2 was set -c to 0 at end of first part of jump beam -c - ivbj2 = ivx -c -c Check for xtup since we bypassed beamstrt wherein vxtup is normally set -c - if (btest(irest(ivx,ip),28) .and. ixrest(ivx).ne.2) - * vxtup(ivx) = .true. -c -c Since beamstrt is not called, and drawbm is normally set there, need to set -c it here. This could cause problems if someone tries a staff-jumping, -c unbarred beam, which I'll deal with when it comes up. -c - drawbm(ivx) = .true. - end if - if (ixrest(ivx) .eq. 0) then - beamon(ivx) = .true. - bspend = .true. - if (.not.btest(irest(ivx,ip),24))bspend = .true. - end if - end if -c -c Setup for chords and possible slurs in chords -c - if (btest(ipl(ivx,ip),10)) then -c -c There is a chord on this note. Just rerun precrd. Klunky, but saves -c me from tracking down errors instroduced when I moved 1st call -c forward for accidental spacing analysis. -c - if (beamon(ivx)) then - call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), - * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt(ivx)), - * .true.,icashft) - else - call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), - * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip), - * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv), - * .true.,icashft) - end if - end if -c -c Is there slur or grace activity? -c - isgrace = btest(islur(ivx,ip),4) - if (ip .gt. 1) isgrace = isgrace.or.btest(ipl(ivx,ip-1),31) -c -c isgrace if not 1st note in bar and previous note has Way-after grace. -c - if (btest(islur(ivx,ip),0) .or. isgrace) then - if (btest(islur(ivx,ip),0)) then - if (fontslur) then -c -c Call routine for non-postscript slurs -c - call doslur(nolev(ivx,ip),isdat1,isdat2,isdat3,nsdat, - * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout, - * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip), - * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)), - * nacc(ivx,ip)) - else -c -c Postscript slurs -c - call dopsslur(nolev(ivx,ip),isdat1,isdat2,isdat3, - * isdat4,nsdat, - * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout, - * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip), - * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)), - * nacc(ivx,ip)) - end if - end if - if (isgrace) then -c -c Grace note. -c - iphold = ip - isgrace = .false. - if (ip .gt. 1) isgrace = btest(ipl(ivx,ip-1),31) - if (isgrace) iphold = iphold-1 - isgrace = isgrace .or. (.not.btest(ipl(ivx,ip),31) - * .and..not.btest(ipl(ivx,ip),29)) -c -c Place grace now if (a) Way-after from prev note and ip>1 or (b) Pre-grace -c on current note. Do A-grace on current note, and W-grace at barend, later. -c - if (isgrace) then - call dograce(ivx,iphold,ptgr,soutq,lsout,ncmid(iv,ip), - * nacc(ivx,ip),ig,ipl(ivx,iphold),.false., - * beamon(ivx),nolev(ivx,ip),ncmid(iv,ip), - * islur(ivx,ip),nvmx(iv),nv,ibmcnt(ivx), - * tnote(ipl2(ivx,ip)),ulq) - if (slurg(ig)) then -c -c Terminate slur started in dograce. Get direction of main note stem -c - if (.not.beamon(ivx)) then -c -c Separate note. Get stem direction. -c - stemup = udqq(nolev(ivx,ip),ncmid(iv,ip), - * islur(ivx,ip),nvmx(iv),ivx,nv) .eq. 'u' - else -c -c In a beam -c - stemup = ulq(ivx,ibmcnt(ivx)) .eq. 'u' - end if -c -c Stop the shift if whole note -c - stemup = stemup .or. - * tnote(ipl2(ivx,ip)).gt.63 - call endslur(stemup,.not.upg(ig),nolev(ivx,ip),0, - * ndxslur,0,ncmid(iv,ip),soutq,lsout,fontslur) - end if - end if - end if - if (btest(iornq(ivx,ip),24)) then -c -c Start slur on main note for After- or Way-after-grace. -c -c???? ndxslur = log2(33554431-listslur) - ndxslur = log2(16777215-listslur) -c -c Get note name -c - call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) -c -c Get slur direction -c - slurudq = 'u' - if (.not.beamon(ivx)) then - if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), - * nvmx(iv),ivx,nv) .eq. 'u') slurudq = 'd' - else - if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') slurudq = 'd' - end if -c -cc Replace ndxslur by 11-ndxslur when printing only. -c Replace ndxslur by 23-ndxslur when printing only. -c -c if (11-ndxslur .lt. 10) then - if (23-ndxslur .lt. 10) then -c notexq = sq//'islur'//slurudq//chax(59-ndxslur) - notexq = sq//'islur'//slurudq//chax(71-ndxslur) - * //noteq(1:lnoten) - call addstr(notexq,8+lnoten,soutq,lsout) - else if (23-ndxslur .lt. 20) then - notexq = sq//'islur'//slurudq//'{1'//chax(61-ndxslur) - * //'}'//noteq(1:lnoten) - call addstr(notexq,11+lnoten,soutq,lsout) - else - notexq = sq//'islur'//slurudq//'{2'//chax(51-ndxslur) - * //'}'//noteq(1:lnoten) - call addstr(notexq,11+lnoten,soutq,lsout) - end if -c call setbits(ipl(ivx,ip),4,23,ndxslur) - call setbits(ipl(ivx,ip),5,23,ndxslur) - if (btest(ipl(ivx,ip),31)) -c -c Starting slur on W-grace on THIS note. Record ndxslur. -c - * listslur = ibset(listslur,ndxslur) - end if - end if -c -c Process dynamic marks -c - if (btest(irest(ivx,ip),26)) then - call dodyn(ivx,ip, - * nolev(ivx,ip),ncmid(iv,ip),ipl(ivx,ip),islur(ivx,ip), - * irest(ivx,ip),nvmx(iv),nv,beamon(ivx),ihornb,nornb,ulq, - * ibmcnt(ivx),nodur(ivx,ip).ge.64,soutq,lsout) - end if -c -c Check for chord notes. Moved up from below, 10/27/96 so chord orns done 1st. -c - if (btest(ipl(ivx,ip),10)) then -c -c Need a duration to set type of note head -c -c if (.not. vxtup(ivx)) then -c -c Clumsy test, but vxtup is not set until main note is processed. -c - if (.not.(vxtup(ivx).or.btest(irest(ivx,ip),28))) then - nodu = nodur(ivx,ip) -c else if (mult(ivx,ip) .lt. 0) then - else if (iand(mult(ivx,ip),15)-8 .lt. 0) then - nodu = 32 - else - nodu = 16 - end if - call docrd(ivx,ip,nodu,ncmid(iv,ip),iv,tnow,soutq,lsout, - * ulq,ibmcnt(ivx),islur(ivx,ip),nvmx(iv),nv, - * beamon(ivx),nolev(ivx,ip),ihornb,nornb,stemlen, - * btest(nacc(ivx,ip),27),nacc(ivx,ip)) - end if -c -c Now that chords are done, add stuff to midi file -c -c if (ismidi) call addmidi(icm,nolev(ivx,ip), - if (ismidi) call addmidi(icm, - * nolev(ivx,ip)-iTransAmt(instno(iv)), -c - * iand(nacc(ivx,ip),7),isig,tnote(ipl2(ivx,ip)), - * btest(irest(ivx,ip),0),.false.) -c -c Check for breath or caesura -c - if (btest(iornq(ivx,ip),28)) then - call putcb(ivx,ip,notexq,lnote) - call addstr(notexq,lnote,soutq,lsout) - end if -c -c Check for main-note ornaments. ')' on dotted notes go in with note, not here. -c Bits 0-13: (stmgx+Tupf._) ; 14: Down fermata, was F -c 15: Trill w/o "tr", was U , 16-18 edit. accid., 19-21 TBD -c - isacc = iand(iornq(ivx,ip),4194287) .gt. 0 -c -c isacc=.true. if any ornament except segno -c - if (btest(iornq(ivx,ip),13) .and. nodur(ivx,ip).gt.0) then -c -c If ). is only ornament, bypass. If with others, temporarirly zero the bit. -c - if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then - if (iand(iornq(ivx,ip),516079) .eq. 0) then -c -c ). is the only non-segno ornament -c - isacc = .false. - else -c -c There are other ornaments in addition -c - rpndot = .true. - iornq(ivx,ip) = ibclr(iornq(ivx,ip),13) - end if - end if - end if - if (isacc .and. .not.cwrferm(ivx)) then -c -c Check for centered whole-bar rest with fermata (bits 10 or 14). -c - if (iand(iornq(ivx,ip),17408).gt.0 - * .and. btest(irest(ivx,ip),0) .and. - * nodur(ivx,ip).eq.lenbar .and. - * .not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)) then - cwrferm(ivx) = .true. - go to 30 - end if - call putorn(iornq(ivx,ip),nolev(ivx,ip),nolev(ivx,ip), - * nodur(ivx,ip),nornb,ulq,ibmcnt(ivx),ivx,ncmid(iv,ip), - * islur(ivx,ip),nvmx(iv),nv,ihornb,stemlen, - * notexq,lnote,ip,islhgt,beamon(ivx), - * btest(ipl(ivx,ip),10)) - call addstr(notexq,lnote,soutq,lsout) - end if - if (rpndot) then - iornq(ivx,ip) = ibset(iornq(ivx,ip),13) - rpndot = .false. - end if -30 continue -c -c Check for main note accidental -c - if (iand(nacc(ivx,ip),3).gt.0 .and. - * .not.btest(nacc(ivx,ip),17)) then - ihshft = igetbits(nacc(ivx,ip),7,10) - if (ihshft .ne. 0) ihshft=ihshft-107 - if (.not.btest(ipl(ivx,ip),10) .and. btest(ipl(ivx,ip),8)) -c -c Not a chord, and left-shifted main note, so left-shift accid -c - * ihshft = ihshft-20 - call doacc(ihshft,igetbits(nacc(ivx,ip),6,4), - * notexq,lnote,nacc(ivx,ip),nolev(ivx,ip),ncmid(iv,ip), - * btest(irest(ivx,ip),31)) - call addstr(notexq,lnote,soutq,lsout) - end if -c -c Lower dot for lower-voice notes. Conditions are: -c 1. Dotted time value -c 2. Lower voice of two -c 3. Note is on a line -c 4. Not a rest -c. 5. Flag (lowdot) is set to true -c 6. Not in an xtuplet -c - if (lowdot .and. nvmx(iv).eq.2 .and. ivx.le.nv - * .and. nodur(ivx,ip).ne.0) then - if (.not.btest(irest(ivx,ip),0) .and. - * 2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip) .and. - * mod(nolev(ivx,ip)-ncmid(ivx,ip),2).eq.0) then - if (btest(irest(ivx,ip),19)) then -c -c Note already in movdot list. Drop by 2. -c - updot(ivx,ndotmv(ivx)+1) = - * updot(ivx,ndotmv(ivx)+1)-2. - else -c -c Not in list so just move it right now -c - call dotmov(-2.,0.,soutq,lsout, - * igetbits(islur(ivx,ip),1,3)) - end if - end if - end if -c -c Check for dotted notes with moved dots -c - if (btest(irest(ivx,ip),19)) then - ndotmv(ivx) = ndotmv(ivx)+1 - call dotmov(updot(ivx,ndotmv(ivx)),rtdot(ivx,ndotmv(ivx)), - * soutq,lsout,igetbits(islur(ivx,ip),1,3)) - end if -c -c Stemlength shortening? -c - if (btest(mult(ivx,ip),27)) then - stemshort = 4.66-.667*(igetbits(mult(ivx,ip),3,28)+1)*.5 - call addstr(sq//'stemlength{',12,soutq,lsout) - write(notexq,'(f4.2)')stemshort - call addstr(notexq(1:4)//'}',5,soutq,lsout) - else if (ip .gt. 1) then - if (btest(mult(ivx,ip-1),27)) -c -c Cancel shortening. Looks like it gets automatically restored if new inst. or -c new line, so no need to worry about affecting other lines -c - * call addstr(sq//'stemlength{4.66}',17,soutq,lsout) - end if -c -c Zero out slur-height marker for raising ornaments -c - islhgt = 0 -c -c Now start with spacing notes. Is a beam start pending? -c - if (bspend .and. - * ibm2(ivx,ibmcnt(ivx)).gt.ibm1(ivx,ibmcnt(ivx))) then - if (ixrest(ivx) .eq. 4) then -c -c Special path for single note at end of otherwise beamed xtup -c - ixrest(ivx) = 0 - else - call beamn1(notexq,lnote) - end if - bspend = .false. -c -c Is a beam ending? -c - else if (numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) -c * .and. ibm2(ivx,ibmcnt(ivx)) .eq. ip) then - * .and. (ibm2(ivx,ibmcnt(ivx)).eq.ip .or. - * btest(nacc(ivx,ip),20))) then - if (bspend) then -c -c Must be a single-note ending of a jump-beam -c - bspend = .false. - end if - call beamend(notexq,lnote) - if (.not.btest(nacc(ivx,ip),20)) then - vxtup(ivx) = .false. - nornb(ivx) = 0 - ibmcnt(ivx) = ibmcnt(ivx)+1 - beamon(ivx) = .false. - end if -c -c Or if we're in the middle of a beam -c - else if (numbms(ivx).gt.0 .and. beamon(ivx)) then - call beamid(notexq,lnote) -c -c Or whole-bar rest -c - else if (btest(irest(ivx,ip),0) - * .and. nodur(ivx,ip).eq.lenbar - * .and..not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0) - * .and..not.btest(irest(ivx,ip),25) - * .and..not.btest(islur(ivx,ip),29)) then -c -c Rule out pickup bar, blank rests, non-centered. Remember islur b19=> rp -c - cwrest(ivx) = .true. - iscwr = .true. - call notex(cwrq(ivx),lcwr(ivx)) - tnow = tnow+lenbar - go to 10 - else if (ixrest(ivx) .eq. 0) then -c -c Before writing note or rest, check for keyboard rest height adjustment. -c Conditions are 0. This is a non-blank rest -c 1. kbdrests = .true. -c 2. There are two voices on the staff -c 3. No user-def height adjustments have been applied (nolev<50) -cc 4. Not last note in bar -cc 5. Followed by note (add better test later) -c - if (kbdrests .and. btest(irest(ivx,ip),0) .and. - * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and. -c * nolev(ivx,ip).le.50 .and. ip.ne.nn(ivx) -c * .and. .not.(btest(irest(ivx,ip+1),0))) then - * nolev(ivx,ip).le.50) then -c -c Get reference level: next following note if no intervening blank rests, -c otherwise next prior note. -c -c levnext = nolev(ivx,ip+1)-ncmid(iv,ip)+4 ! Relative to bottom line - if (ip.ne.nn(ivx).and..not.btest(iornq(ivx,ip),30)) then -c -c Not the last note and not "look-left" for level -c - do 8 kkp = ip+1 , nn(ivx) - if (btest(islur(ivx,kkp),29)) go to 4 - if (.not.btest(irest(ivx,kkp),0)) then - levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line - go to 9 - end if -8 continue - end if -4 continue -c -c If here, there were no following notes or came to a blank rest, or -c "look-left" option set. So look before -c - if (ip .eq. 1) go to 2 ! Get out if this is the first note. - do 3 kkp = ip-1, 1, -1 - if (.not.btest(irest(ivx,kkp),0)) then - levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line - go to 9 - end if -3 continue - go to 2 ! Pretty odd, should never be here, but get out if so. -9 continue -c -c Find note in other voice at same time -c - iupdown = sign(1,ivx-nv-1) - ivother = ivmx(iv,(3-iupdown)/2) - tother = 0. - do 5 kkp = 1 , nib(ivother,ibar) - if (abs(tother-tnow) .lt. tol) go to 6 - tother = tother+nodur(ivother,kkp) -5 continue -c -c If here, then no note starts in other voice at same time, so set default -c - levother = -iupdown*50 - go to 7 -6 continue -c -c If here, have just identified a simultaneous note or rest in other voice -c - if (.not.btest(irest(ivother,kkp),0)) then ! Not a rest, use it - levother = nolev(ivother,kkp)-ncmid(iv,ip)+4 - else - if (nodur(ivother,kkp) .eq. nodur(ivx,ip)) then -c -c Rest in other voice has same duration, get out (so defualt spacing is used) -c - go to 2 - end if - levother = -iupdown*50 - end if -7 continue - indxr = log2(nodur(ivx,ip))+1 - if (iupdown .lt. 0) then - levtop = levtopr(indxr) - iraise1 = levother-levtop-3 ! Based on other note - iraise2 = levnext-levtop ! Based on following note - if (indxr.eq.5 .and. levnext.lt.1) iraise2=iraise2+2 - iraise = min(iraise1,iraise2) - if (mod(iraise+50,2).eq.1 .and. - * iraise+levtop.gt.-1) iraise = iraise-1 - else - levbot = levbotr(indxr) - iraise1 = levother-levbot+3 - iraise2 = levnext-levbot - if (indxr.eq.5 .and. levnext.gt.8) iraise2=iraise2-1 - iraise = max(iraise1,iraise2) - if (mod(iraise+50,2).eq.1 .and. - * iraise+levbot.le.9) iraise = iraise-1 - end if - nolev(ivx,ip) = 100+iraise - end if -2 continue -c -c Write a separate note or rest -c - call notex(notexq,lnote) - end if -c -c Right offset? This may cause trouble -c - if (btest(ipl(ivx,ip),8)) then - call addstr(sq//'loff{',6,soutq,lsout) - else if (btest(ipl(ivx,ip),9)) then - call addstr(sq//'roff{',6,soutq,lsout) - end if - if (ixrest(ivx).eq.0 .and. lnote.gt. 0) - * call addstr(notexq,lnote,soutq,lsout) - if (btest(ipl(ivx,ip),8) .or. - * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout) -c -c Terminate user-defined offsets. Fix format -c - if (btest(irest(ivx,ip),15) .or. btest(irest(ivx,ip),17)) - * call putshft(ivx,.false.,soutq,lsout) -c -c Deal with After- and Way-after-graces. First, if end of bar, compute space -c needed since it wasn't done during general ask-checks. If extra space is -c rq'd, convert GW to GA. Therefore GW at end of bar never needs extra sp. -c But will still need to add extra space as hardspace. -c - if (ip.eq.nn(ivx) .and. (btest(ipl(ivx,ip),31).or. - * btest(ipl(ivx,ip),29))) then - do 77 ig = 1 , ngrace - if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 78 -77 continue - print*,'Problem finding grace index at "do 77"' - call stop1() -78 continue -c -c Get elemskip to end of bar. WON'T WORK IF XTUPS !! -c - esk = 0. - do 40 iib = ib , nb - if (iib .eq. ib) then - itleft = nint(to(ipl2(ivx,ip))) - else - itleft = nint(tstart(ib)) - end if - if (iib .lt. nb) then - itright = nint(tstart(iib+1)) - else - itright = lenbar - end if - esk = esk+feon(space(ib))* - * (itright-itleft)/space(ib) -40 continue - ptsavail = poenom*esk-wheadpt - if (nng(ig) .eq. 1) then - wgr = grafac - else - wgr = nng(ig)*emgfac - do 41 ing = 1 , nng(ig) - if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac -41 continue - end if - ptgr(ig) = wgr*wheadpt - ptsneed = (wgr+0.5)*wheadpt - ptsndg(ivx) = 0. - if (ptsavail .lt. ptsneed) then - ptsndg(ivx) = ptsneed - eskndg(ivx) = esk - if (btest(ipl(ivx,ip),31)) then -c -c Convert GW to GA -c - ipl(ivx,ip) = ibset(ibclr(ipl(ivx,ip),31),29) - end if - end if - end if -c -c Check for GA -c - if (btest(ipl(ivx,ip),29)) - * call dograce(ivx,ip,ptgr,soutq,lsout,ncmid(iv,ip), - * nacc(ivx,ip),ig,ipl(ivx,ip),.false., - * .false.,0,0,0,0,0,0,0.,ulq) -c -c Update running time -c - tnow = tnow+space(ib) -10 continue -c -c Have finished last note in this voice and block -c - itendb = nint(to(istop(ib))+space(ib)) - if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then - ivf = 1 - if (ivx .gt. 1) ivf = 2 -17 if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.itendb) then -c -c There's at least one figure left. offnsk could be <0 -c - offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib) - call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq,lsout) - go to 17 - end if - end if -c -c Check for flag, dot, or upstem on last note of bar. -c - if (ib .eq. nb) then - ip = ipo(ipl2(ivx,nn(ivx))) - flgndv(ivx) = 0. - if (abs(tnote(ipl2(ivx,ip))-space(ib)).lt.tol) then - if (space(ib) .lt. 16.-tol) then -c -c Note in last space, smaller than a quarter note. -c - if ((.not.btest(irest(ivx,ip),0) .and. - * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), - * nvmx(iv),ivx,nv).eq.'u') - * .or. isdotted(nodur,ivx,ip)) then -c -c Upstem non-rest, or dotted -c - if (numbms(ivx).gt.0 - * .and. ip.eq.ibm2(ivx,max(1,numbms(ivx))) - * .and. .not.isdotted(nodur,ivx,ip)) - * then -c -c In beam and not dotted, so use smaller space -c - flgndv(ivx) = upstmfac - else - flgndv(ivx) = flagfac - end if - end if - else -c -c Last space, nonflagged (no beam) only worry dot or up -c - if (isdotted(nodur,ivx,ip)) then - flgndv(ivx) = flagfac - else if (tnote(ipl2(ivx,ip)).lt.64 .and. - * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), - * nvmx(iv),ivx,nv).eq.'u') then -c -c Upstem on last note , non-flagged -c - flgndv(ivx) = upstmfac - end if - end if - end if -c -c Check for right-shifted chordal note -c - if (btest(irest(ivx,ip),20)) flgndv(ivx) = rtshfac - flgndb = flgndb .or. flgndv(ivx).gt.0. - if (ismidi) then -c -c For midi, set flags for accidentals on last note of bar. Assume they affect -c first note of next bar whether or not tied. -c Note has already been done, so next entry into addmidi is 1st in new bar. -c First do main note, then chord notes -c -c Gyrations needed to account for multi-bar tied full-bar notes? -cc Old old lbacc(icm) = iand(nacc(ivx,ip),7) -c New old if (lbacc(icm).eq.0) lbacc(icm) = iand(nacc(ivx,ip),7) -c - if (iand(nacc(ivx,ip),7) .gt. 0) then -c -c Explicit accidental on last main note in bar -c - do 55 kacc = 1 , naccbl(icm) - if (laccbl(icm,kacc) .eq. nolev(ivx,ip)) go to 56 -55 continue - naccbl(icm) = naccbl(icm)+1 - laccbl(icm,naccbl(icm)) = nolev(ivx,ip) - jaccbl(icm,naccbl(icm)) = iashft(iand(nacc(ivx,ip),7)) - end if -56 continue - if (btest(ipl(ivx,ip),10) .and. crdacc) then - do 57 icrd = icrd1 , icrd2 - iacc = igetbits(icrdat(icrd),3,20) - if (iacc .gt. 0) then -c -c Explicit accidental on chord note at end of bar -c - nolevc = igetbits(icrdat(icrd),7,12) - do 58 kacc = 1 , naccbl(icm) - if (laccbl(icm,kacc) .eq. nolevc) go to 59 -58 continue - naccbl(icm) = naccbl(icm)+1 - laccbl(icm,naccbl(icm)) = nolevc - jaccbl(icm,naccbl(icm)) = iashft(iacc) - end if -59 continue -57 continue - end if -c if (lbacc(icm).eq.0 .and. accb4(icm)) then - do 65 kacc = 1 , naccim(icm) -c -c If naccim(icm)>0, -c possible implicit accidental from earlier in the bar. Check for prior accid -c in this bar at relevant note levels, main and chord notes. Only act if no -c explicit action from just above. Assuming any accid on last note in bar, -c either explicit or implicit, has same effect on 1st note of next bar. -c - if (nolev(ivx,ip) .eq. laccim(icm,kacc)) go to 66 - if (btest(ipl(ivx,ip),10)) then - do 67 icrd = icrd1 , icrd2 - if (iand(ishft(icrdat(icrd),-12),127) .eq. - * laccim(icm,kacc)) go to 66 -67 continue - end if - go to 65 -66 continue -c -c So far we know there is a main or chord note at level laccim(icm,kacc). So -c it will get a bl-accid if it didn't just already get one. -c - do 68 macc = 1 , naccbl(icm) - if (laccbl(icm,macc) .eq. laccim(icm,kacc)) go to 65 -68 continue - naccbl(icm) = naccbl(icm)+1 - laccbl(icm,naccbl(icm)) = laccim(icm,kacc) - jaccbl(icm,naccbl(icm)) = jaccim(icm,kacc) -65 continue - end if - end if -11 continue -c -c Close out the notes group -c - call addstr(sq//'en',3,soutq,lsout) - if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%' -16 continue -c -c Check for way-after graces at end of bar. We could not link these to notes -c as in midbar since there is no note following grace! Also, set flag if -c hardspace is needed. Also, save nvmx, ivmx for use in space checks on reloop. -c - isgrace = .false. - do 75 iv = 1 , nv - nvmxsav(iv) = nvmx(iv) - do 75 kv = 1 , nvmx(iv) - ivmxsav(iv,kv) = ivmx(iv,kv) - ivx = ivmx(iv,kv) - ptsgnd = 0. - if ((btest(ipl(ivx,nn(ivx)),29).or.btest(ipl(ivx,nn(ivx)),31)) - * .and. ptsndg(ivx).gt.0.) then - flgndb = .true. - if (ptsndg(ivx) .gt. ptsgnd) then - ptsgnd = ptsndg(ivx) - eskgnd = eskndg(ivx) - end if - end if - if (btest(ipl(ivx,nn(ivx)),31)) then -c -c This voice has a way-after grace here at end of bar -c - if (.not.isgrace) then -c -c This is the first one, so set up the string -c - isgrace = .true. - ivlast = 1 - soutq = sq//'znotes' - lsout = 7 - end if - do 76 iiv = ivlast , iv-1 - call addstr(sepsymq(iiv),1,soutq,lsout) -76 continue - ivlast = iv -c -c No need to put in 'nextvoice', even if 2 lines/staff -c - call dograce(ivx,nn(ivx),ptgr,soutq,lsout,ncmid(iv,nn(ivx)), - * nacc(ivx,nn(ivx)),ig,ipl(ivx,nn(ivx)),.true., - * .false.,0,0,0,0,0,0,0.,ulq) - end if -75 continue - if (isgrace) then - call addstr(sq//'en%',4,soutq,lsout) - if (islast .and. lsout .gt. 0) write(11,'(a)')soutq(1:lsout) - end if - lsout = 0 -c -c Write multibar rest. Assuming nv = 1 and do not worry about cwbrest -c This has to be the only use of atnextbar -c -c if (ibar .eq. ibarmbr) then - if (ibar.eq.ibarmbr .and. islast) then -c call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes'//sq// -c * 'mbrest{',30,soutq,lsout) -c ndig = int(alog10(mbrest+.01))+1 -c write(soutq(31:33),'(i'//chax(48+ndig)//')')mbrest -c lsout = lsout+ndig -c call addstr('}{',2,soutq,lsout) -c mtrspc = .5+xb4mbr -c xb4mbr = 0. -c if (mtrspc .eq. 0) then -c ndig = 1 -c else -c ndig = int(alog10(mtrspc+.01))+1 -c end if -c write(soutq(lsout+1:lsout+2),'(i'//chax(48+ndig)//')')mtrspc -c lsout = lsout+ndig -c call addstr('}0'//sq//'en}%',7,soutq,lsout) -c if (islast) write(11,'(a)')soutq(1:lsout) -c lsout = 0 -c ndig = int(alog10(mbrest-1+.01))+1 -c if (mbrest.eq.1) ndig=1 -c if (islast) write(11,'(a14,i'//chax(48+ndig)//',a1)') -c * sq//'advance'//sq//'barno',mbrest-1,'%' -c++ - soutq = sq//'def'//sq//'atnextbar{'//sq//'znotes' - lsout = 22 - notexq = sq//'mbrest' - lnote = 7 - call istring(mbrest,noteq,len) - notexq = notexq(1:lnote)//noteq(1:len) - lnote = lnote+len - mtrspc = .5+xb4mbr - xb4mbr = 0. - call istring(mtrspc,noteq,len) - notexq = notexq(1:lnote)//noteq(1:len)//'0' - lnote = lnote+len+1 - do 62 iv = 1 , nv - call addstr(notexq,lnote,soutq,lsout) - if (iv .lt. nv) call addstr(sepsymq(iv),1,soutq,lsout) -62 continue - call addstr(sq//'en}%',5,soutq,lsout) - write(11,'(a)')soutq(1:lsout) - lsout = 0 - if (mbrest .gt. 1) then - ndig = int(alog10(mbrest-1+.01))+1 - write(11,'(a14,i'//chax(48+ndig)//',a1)') - * sq//'advance'//sq//'barno',mbrest-1,'%' - end if - else if (iscwr) then -c -c Centered whole-bar rests -c - call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes',22, - * soutq,lsout) - do 60 iv = 1 , nv - lnote = 0 - do 61 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - if (cwrest(ivx)) then - if (lnote .eq. 0) then - notexq = sq//'centerbar{' - lnote = 11 - end if - if (.not.cwrferm(ivx)) then - if (lcwr(ivx).ge.11 .and. cwrq(ivx)(11:11).ne.'p') then -c -c Kluge to use new definitions for centered, stacked rests -c - if (cwrq(ivx)(2:10).eq.'liftpause' .or. - * cwrq(ivx)(2:10).eq.'liftPAuse') - * cwrq(ivx)(10:10) = 'c' - end if - notexq = notexq(1:lnote)//cwrq(ivx)(1:lcwr(ivx)) - lnote = lnote+lcwr(ivx) - else -c -c Fermata on centered rest. Will need to fix up level. -c 12/6/07 shift it left so it's centered over rest -c -c notexq = notexq(1:lnote) -c * //sq//'fermataup7'//cwrq(ivx)(1:lcwr(ivx)) -c lnote = lnote+11+lcwr(ivx) -c - notexq = notexq(1:lnote)//sq//'loffset{.39}{' - * //sq//'fermataup7}'//cwrq(ivx)(1:lcwr(ivx)) - lnote = lnote+26+lcwr(ivx) - cwrferm(ivx) = .false. - end if - end if -61 continue - if (lnote .gt. 0) call addstr(notexq(1:lnote)//'}',lnote+1, - * soutq,lsout) - if (iv .ne. nv) call addstr(sepsymq(iv),1,soutq,lsout) -60 continue - call addstr(sq//'en}',4,soutq,lsout) - if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%' - end if -c -c End of block for centered whole-bar rests and multi-bar rests -c -c If at end of block, save durations of last notes in bar, for possible use -c if clef changes at start of next bar -c - if (ibar .eq. nbars) then - do 63 iv = 1 , nv - do 63 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) -c prevtn(ivx) = tnote(iand(ipl(ivx,nn(ivx)),255)) - prevtn(ivx) = tnote(ipl2(ivx,nn(ivx))) -63 continue - end if -c -c Update time for midi. This is only used for the event track -c - if (ismidi) then - miditime = miditime+15*lenbar -c -c If pickup, write the real time signature to the event track. Cannot use -c mtrnuml since it was reset to 0, have to recompute it -c - if (lenb0 .eq. lenbar) - * call midievent('m',mtrdenl*lenb1/64,mtrdenl) - end if - return - end - subroutine makeabar() -c -c On input, have pseudo-durations in nodur(ivx,ip). Not real durations for -c xtups, since only last note of xtup gets non-zero nodur, which -c corresponds to single note of full length of xtup. -c In this subroutine we make an ordered list of all notes in all voices. -c ilnc = list note counter -c ivxo(ilnc), ipo(ilnc) = voice# and position in voice of ilnc-th note. -c to(ilnc) = real start time of note in PMX-units (64=whole note) -c tno(ilnc) = time to next event in the bar. -c tnote(ilnc) = actual duration of note -c Then run thru list, grouping consecutive notes into \notes groups ib. -c space(ib) = real time unit for the \notes group -c squez(ib) = factor on space to get effective space. This will be 1 if -c there is a note exactly spanning each interval of space, and -c <1 if not. -c Details: let eon = elemskips per noteskip (like length). Basic formula is -c eon = sqrt(space/2.) -c If tgovern >= space, then -c eon = sqrt(tgovern/2)*(space/tgovern) = space/sqrt(2*tgovern). -c Time needed to give this eon using basic formula is -c teq = space**2/tgovern -c Factor on space to get teq is -c squez(ib) = space/tgovern -c The eon for each ib can then be computed based on time of space*squez. -c Iff squez = 1, there is a note spanning every increment in the \notes group. -c -c tnminb = minimum time span in the bar for increments spanned by notes, -c i.e., with squez=1. Use after parsing into line to decide if -c spacing needs to be "flattened" among notes groups. -c - common /comtol/ tol - parameter (nm=24,nkb=3999,maxblks=4000) - common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), - * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, - * nbars,itsofar(nm),nib(nm,15),nn(nm), - * rest(nm,200),lenbr0,lenbr1,firstline,newmeter - common /linecom/ elskb,tnminb(nkb) - common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), - * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, - * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) - common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) - logical rest,firstline,newmeter,gotclef - integer cnn(nm),istart(80),istop(80) - real*4 xit(nm),space(80),tstart(80),squez(80),tnote(600) - elskb = 0. - tnminb(ibarcnt) = 1000. - do 1 iv = 1 , nv - do 1 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - if (ibar .gt. 1) then - nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1) - else - nn(ivx) = nib(ivx,ibar) - end if -1 continue -c -c initialize list note counter, time(iv), curr. note(iv) -c - ilnc = 1 - do 4 iv = 1 , nv - do 4 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - cnn(ivx) = 1 - ivxo(ilnc) = ivx - ipo(ilnc) = 1 - to(ilnc) = 0. - tnote(ilnc) = fnote(nodur,ivx,1,nacc) - xit(ivx) = tnote(ilnc) - if (abs(xit(ivx)-lenbar).lt.tol) xit(ivx) = 1000. - ilnc = ilnc+1 -4 continue -c -c Build the list -c -5 continue -c -c Determine which voice comes next from end of notes done so far. -c tmin is the earliest ending time of notes done so far -c - tmin = 1000. - do 6 iv = 1 , nv - do 6 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - tminn = min(tmin,xit(ivx)) - if(tminn .lt. tmin) then - tmin = tminn - ivnext = ivx - end if -6 continue - if (tmin .gt. 999.) go to 7 - ivxo(ilnc) = ivnext - cnn(ivnext) = cnn(ivnext)+1 - ipo(ilnc) = cnn(ivnext) - to(ilnc) = tmin -c -c Check if this voice is done -c - tnote(ilnc) = fnote(nodur,ivnext,cnn(ivnext),nacc) - if (cnn(ivnext) .eq. nn(ivnext)) then - xit(ivnext) = 1000. - else - xit(ivnext) = xit(ivnext)+tnote(ilnc) - end if - ilnc = ilnc+1 - go to 5 -7 continue - ntot = ilnc-1 - if (ntot .gt. 600) then - call printl(' ') - call printl('Cannot have more than 600 notes per bar, stopping') - call stop1() - end if - do 8 in = 1 , ntot-1 - tno(in) = to(in+1)-to(in) -8 continue - tno(ntot) = fnote(nodur,ivxo(ntot),ipo(ntot),nacc) - tnote(ntot) = tno(ntot) -c -c Debug writes -c -c write(*,'()') -c write(*,'(16i5)')(ivxo(in),in=1,ntot) -c write(*,'(16i5)')(ipo(in),in=1,ntot) -c write(*,'(16f5.1)')(to(in),in=1,ntot) -c write(*,'(16f5.1)')(tno(in),in=1,ntot) -c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) -c write(*,'(16f5.1)')(tnote(in),in=1,ntot) -c -c Done w/ list. Initialize loop for building note blocks: -c - ib = 1 - istart(1) = 1 - space(1) = 0. - in = 1 -c -c Start the loop -c -9 continue - if (in .eq. ntot) then - if (space(ib) .lt. tol) then - space(ib) = tno(in) -c -c Last gap in bar is spanned by a note, so cannot need a squeeze. -c - squez(ib) = 1. - end if - istop(ib) = ntot -c -c From here flow out of this if block and into block-setup -c - else if (space(ib) .lt. tol) then -c -c space hasn't been set yet, so tentatively set: -c - space(ib) = tno(in) - if (space(ib) .lt. tol) then - in=in+1 - else -c -c Tentative space tno(in) is non-zero. Set squez, which will be kept (since -c it is a unique property of the particular increment starting here) : -c - squez(ib) = getsquez(in,ntot,space(ib),tnote,to) - istop(ib) = in - end if - go to 9 - else if (tno(in+1) .lt. tol) then -c -c This is not the last note in the space, so -c - in = in+1 - go to 9 - else if (abs(tno(in+1)-space(ib)) .lt. tol) then -c -c Next increment has same space. Does it have same squez? -c - xsquez = getsquez(in+1,ntot,space(ib),tnote,to) -c -c If it does have the same squez, loop, otherwise flow out -c - if (abs(xsquez-squez(ib)) .lt. tol) then -c -c Keep spacing the same, update tentative stop point -c - in = in+1 - istop(ib) = in - go to 9 - end if - end if -c -c At this point istart, istop, space, and squez are good, so close out block -c - tstart(ib) = to(istart(ib)) -c -c Compute elemskips assuming no flattening to increase min space. The formula -c is only correct if f1eon(t) = sqrt(t/2); more generally (after possible -c flattening in pmxb), elsperns = squez*feon(space/squez) -c - elsperns = f1eon(space(ib)*squez(ib)) - if (istop(ib) .eq. ntot) then - nnsk = nint((lenbar-tstart(ib))/space(ib)) - else - nnsk = nint((to(istop(ib)+1)-tstart(ib))/space(ib)) - end if - elskb = elskb+elsperns*nnsk - if (nptr(ibarcnt+1) .gt. nptr(ibarcnt)) then - call catspace(space(ib),squez(ib),nnsk) - else -c -c This is the first entry for this bar -c - nnpd(nptr(ibarcnt)) = nnsk - durb(nptr(ibarcnt)) = space(ib) - sqzb(nptr(ibarcnt)) = squez(ib) - nptr(ibarcnt+1) = nptr(ibarcnt+1)+1 - end if -c -c Update minimum space spanned by a note -c - if (abs(squez(ib)-1) .lt. tol) - * tnminb(ibarcnt) = min(tnminb(ibarcnt),space(ib)) - if (istop(ib) .eq. ntot) go to 15 -c -c End of spatial accounting for now -c - ib = ib+1 - istart(ib) = istop(ib-1)+1 - in = istart(ib) -c -c Set tentative block space for new block -c - space(ib) = tno(in) - if (space(ib).gt.tol) - * squez(ib)= getsquez(in,ntot,space(ib),tnote,to) - istop(ib) = in - go to 9 -15 continue -c nb = ib -c -c Debug writes -c -c write(*,'(16i5)')(istart(ib),ib=1,nb) -c write(*,'(16i5)')(istop(ib),ib=1,nb) -c write(*,'(16f5.1)')(space(ib),ib=1,nb) -c write(*,'(16f5.1)')(squez(ib),ib=1,nb) -c - return - end - subroutine midievent(typeq,in1,in2) -c -c We now store "conductor" events in mmidi(numchan,.), and count bytes -c with imidi(numchan) -c - parameter (nm=24,mv=24576) - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - common /comevent/ miditime,lasttime - character*1 typeq - idur = isetvarlen(miditime-lasttime,nbytes) - imidi(numchan) = imidi(numchan)+nbytes+1 - do 1 i = 1 , nbytes - mmidi(numchan,imidi(numchan)-i) = mod(idur,256) - idur = ishft(idur,-8) -1 continue - mmidi(numchan,imidi(numchan)) = 255 - if (typeq .eq. 't') then -c -c Tempo event. in1 = quarters per minute (integer) -c - mmidi(numchan,imidi(numchan)+1) = 5*16+1 - mmidi(numchan,imidi(numchan)+2) = 3 - misperq = nint(60000000./in1) - do 2 i = 1 , 3 - mmidi(numchan,imidi(numchan)+6-i) = mod(misperq,256) - misperq = ishft(misperq,-8) -2 continue - imidi(numchan) = imidi(numchan)+5 - else if (typeq .eq. 'm') then -c -c Meter event. in1=numerator, in2=denom (power of 2) -c - mmidi(numchan,imidi(numchan)+1) = 5*16+8 - mmidi(numchan,imidi(numchan)+2) = 4 - mmidi(numchan,imidi(numchan)+3) = in1 - if (in2 .gt. 0) then - mmidi(numchan,imidi(numchan)+4) = log2(in2) - else - mmidi(numchan,imidi(numchan)+4) = 0 - end if - mmidi(numchan,imidi(numchan)+5) = 24 - mmidi(numchan,imidi(numchan)+6) = 8 - imidi(numchan) = imidi(numchan)+6 - else if (typeq .eq. 'k') then -c -c Keychange event. in1 = isig -c - mmidi(numchan,imidi(numchan)+1) = 5*16+9 - mmidi(numchan,imidi(numchan)+2) = 2 - mmidi(numchan,imidi(numchan)+3) = mod(256+in1,256) - mmidi(numchan,imidi(numchan)+4) = 0 - imidi(numchan) = imidi(numchan)+4 - else - print*,'Program flameout in midievent' - call stop1() - end if - lasttime = miditime - return - end - subroutine moveln(iuin,iuout,done) - logical done - character*129 outq - done = .false. - read(iuin,'(a)',end=1) outq - lenout = llen(outq,129) - write(iuout,'(a)') outq(1:lenout) - return -1 done = .true. - return - end - subroutine mrec1(lineq,iccount,ndxm) -c -c This is called when (a) macro recording is just starting and -c (b) at the start of a new line, if recording is on -c - parameter (maxblks=4000) - character*128 lineq,lnholdq - common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac - logical mrecord,mplay,endmac - common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), - * ic1mac(20),ilmac,iplmac - character*65536 bufq - integer*2 lbuf(maxblks) - common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq - if (.not.mrecord) then -c -c Starting the macro -c - ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount - il1mac(macnum) = ilbuf-1 - ic1mac(macnum) = iccount - mrecord = .true. - end if - if (iccount .lt. 128) then - ndxm = index(lineq(iccount+1:128),'M') - if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M', - * 128-iccount) - if (ndxm .gt. 0) then -c -c This line ends the macro. -c - ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm - il2mac(macnum) = ilbuf-1 - mrecord = .false. - end if - end if - return - end - function ncmid(iv,ip) - parameter (nm=24) - common /all/ mult(nm,200),jv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - common /comipl2/ ipl2(nm,200) - character*1 ulq,sepsymq,sq - logical beamon,firstgulp,figbass,figchk,isfig - common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), - * ndotmv(nm),updot(nm,20),rtdot(nm,20) - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /comtol/ tol - if (ncc(iv) .eq. 1) then - ncmid = ncmidcc(iv,1) - else - xtime = to(ipl2(ivx,ip)) - do 1 icc = ncc(iv) , 1 , -1 - if (xtime .gt. tcc(iv,icc)-tol) then - ncmid = ncmidcc(iv,icc) - return - end if -1 continue - print*,'Problem in ncmid()' - stop - end if - end - function ncmidf(clefq) -c -c Return middle line of a clef -c - character*1 clefq -c if (clefq.eq.'t' .or. clefq.eq.'0') then -c ncmidf = 35 -c else if (clefq.eq.'s' .or. clefq.eq.'1') then -c ncmidf = 33 -c else if (clefq.eq.'m' .or. clefq.eq.'2') then -c ncmidf = 31 -c else if (clefq.eq.'a' .or. clefq.eq.'3') then -c ncmidf = 29 -c else if (clefq.eq.'n' .or. clefq.eq.'4') then -c ncmidf = 27 -c else if (clefq.eq.'r' .or. clefq.eq.'5') then -c ncmidf = 25 -c else if (clefq.eq.'f' .or. clefq.eq.'7') then -c ncmidf = 37 -c else -c ncmidf = 23 -c end if - ncmidf = 21+index(' b6r5n4a3m2s1t0f7',clefq)/2*2 - return - end - subroutine newvoice(jv,clefq,change) - parameter (nm=24) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - character*1 ulq,sepsymq,sq - logical beamon,firstgulp,figbass,figchk,isfig - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, - * tautofb,autofbon,t1autofb - character*1 ulfbq,clefq - common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), - * ndotmv(nm),updot(nm,20),rtdot(nm,20) - common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) - logical change,autofbon - nvmx(jv) = 1 - ivmx(jv,1) = jv - itsofar(jv) = 0 - nnl(jv) = 0 - nfb(jv) = 0 - if (firstgulp .or. change) then - ncmidcc(jv,1) = ncmidf(clefq) - else - ncmidcc(jv,1) = ncmidcc(jv,ncc(jv)) - end if - tcc(jv,1) = 0. - ncc(jv) = 1 - nudoff(jv) = 0 - ndotmv(jv) = 0 - do 5 j = 1 , 200 - irest(jv,j) = 0 - islur(jv,j) = 0 - ipl(jv,j) = 0 - nacc(jv,j) = 0 - iornq(jv,j) = 0 - mult(jv,j) = 0 - if (jv.le.2) isfig(jv,j) = .false. -5 continue - return - end - subroutine notefq(noteq,lnote,nolev,ncmid) -c -c Returns name of note level with octave transpositions, updates noctup. -c - common /comoct/ noctup - character*8 noteq - character*1 upcaseq,noteqt,chax - nupfroma = mod(nolev+1,7) - iname = 97+nupfroma - ioctup = (nolev+1)/7-4 - noteqt = chax(iname) - if (ncmid .eq. 23) noteqt = upcaseq(noteqt) - if (ioctup .eq. noctup) then - noteq = noteqt - lnote = 1 -c -c Must ALWAYS check if lnote=1 for use with functions requiring a blank -c - else if (ioctup .gt. noctup) then -c -c Raise octave. Encase in {} -c - write(noteq,'(8a1)')'{',(chax(39),i=noctup,ioctup-1), - * noteqt,'}' - lnote = 3+ioctup-noctup - noctup = ioctup - else -c -c Lower octave -c - write(noteq,'(8a1)')'{',(chax(96),i=ioctup,noctup-1), - * noteqt,'}' - lnote = 3+noctup-ioctup - noctup = ioctup - end if - return - end - subroutine notex(notexq,lnote) -c -c Returns non-beamed full note name -c - parameter (nm=24) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - character*1 ulq,sepsymq,sq - logical beamon,firstgulp,figbass,figchk, - * isfig,ispoi,btest,even - character*1 udq,udqq,chax - character*4 dotq - character*2 numq - character*79 notexq - character*8 noteq - character*40 restq - common /compoi/ ispoi - common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), - * fullsize(nm),ivxfig2 - character*10 figq - ip = ipo(jn) - nole = nolev(ivx,ip) -c -c Check for special situations with 2nds (see precrd) -c - if (btest(nacc(ivx,ip),30)) then - nole = nole - 1 - else if (btest(nacc(ivx,ip),31)) then - nole = nole + 1 - end if - nodu = nodur(ivx,ip) - if (.not.btest(irest(ivx,ip),0)) then - udq = udqq(nole,ncmid(iv,ip), - * islur(ivx,ip),nvmx(iv),ivx,nv) - end if -c -c Check figure level -c -c if (figbass .and. isfig(ivx,ip) -c * .and. .not.btest(irest(ivx,ip),0)) then - if (figbass .and. .not.btest(irest(ivx,ip),0) .and. - * ((ivx.eq.1.and.isfig(1,ip)) - * .or.(ivx.eq.ivxfig2.and.isfig(2,ip)))) then - if (udq .eq. 'u' .or. nodu.ge.64) then -c -c Upper or no stem, fnole (in noleunits) set by notehead -c - fnole = nole - else -c -c Lower stem, fnole set by bottom of stem -c - fnole = nole-stemlen - end if - zmin = fnole-ncmid(ivx,ip)+4 - if (ivx .eq. 1) then - ifigdr(1,iline) = max(ifigdr(1,iline),nint(4-zmin)) - else - ifigdr(2,iline) = max(ifigdr(2,iline),nint(4-zmin)) - end if - end if - if (.not.btest(irest(ivx,ip),0)) then - call notefq(noteq,lnoten,nole,ncmid(iv,ip)) - if (lnoten .eq. 1) call addblank(noteq,lnoten) - if (nodu .eq. 1) then - notexq =sq//'cccc'//udq//noteq(1:lnoten) - lnote = lnoten+6 - else if (nodu .eq. 2) then - notexq =sq//'ccc'//udq//noteq(1:lnoten) - lnote = lnoten+5 - else if (nodu .eq. 4) then - notexq =sq//'cc'//udq//noteq(1:lnoten) - lnote = lnoten+4 - else if (nodu .eq. 8) then - notexq =sq//'c'//udq//noteq(1:lnoten) - lnote = lnoten+3 - else if (nodu .eq. 16) then - notexq =sq//'q'//udq//noteq(1:lnoten) - lnote = lnoten+3 - else if (nodu .eq. 32) then - notexq =sq//'h'//udq//noteq(1:lnoten) - lnote = lnoten+3 - else if (nodu .eq. 64) then - notexq =sq//'wh'//noteq(1:lnoten) - lnote = lnoten+3 - else if (nodu .eq. 128) then -c notexq =sq//'zbreve'//noteq(1:lnoten)//sq//'sk' -c lnote = lnoten+10 - notexq =sq//'breve'//noteq(1:lnoten) - lnote = lnoten+6 - else - dotq = 'p' - ldot = 1 - if (btest(iornq(ivx,ip),13)) then -c -c Dotted note with ')' ornament -c - dotq='m' - else if (btest(islur(ivx,ip),3)) then -c -c Double dot -c - dotq = 'pp' - ldot = 2 - end if - if (nodu .ge. 192) then - notexq =sq//'breve'//dotq(1:ldot)//noteq(1:lnoten) - lnote = lnoten+6+ldot - else if (nodu .ge. 96) then - notexq =sq//'wh'//dotq(1:ldot)//noteq(1:lnoten) - lnote = lnoten+3+ldot - else if (nodu .ge. 48) then - notexq =sq//'h'//udq//dotq(1:ldot)//noteq(1:lnoten) - lnote = lnoten+3+ldot - else if (nodu .ge. 24) then - notexq =sq//'q'//udq//dotq(1:ldot)//noteq(1:lnoten) - lnote = lnoten+3+ldot - else if (nodu .ge. 12) then - notexq =sq//'c'//udq//dotq(1:ldot)//noteq(1:lnoten) - lnote = lnoten+3+ldot - else if (nodu .ge. 6) then - notexq =sq//'cc'//udq//dotq(1:ldot)//noteq(1:lnoten) - lnote = lnoten+4+ldot - ispoi = .true. - else - notexq =sq//'ccc'//udq//dotq(1:ldot)//noteq(1:lnoten) - lnote = lnoten+5+ldot - ispoi = .true. - end if - if (dotq(1:1) .eq. 'm') then -c -c Need another call to the note, in case the first one has octave shifts -c - if (lnoten .eq. 2) then - notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}' - lnote = lnote+3 - else - notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) - lnote = lnote+1 - end if - end if - end if - else if (btest(islur(ivx,ip),29)) then -c -c Blank rest -c - notexq = sq//'sk' - lnote = 3 - else -c -c Non-blank rest -c - lnote = 0 - nole = mod(nole+20,100)-20 -c -c Kluge to get pause symbol for rp: -c - if (btest(islur(ivx,ip),19)) nodu = 64 - if (nodu .le. 28) then -c -c Normal rest < or = double-dotted quarter -c - lrest = 3 - if (nodu .gt. 14) then - restq =sq//'qp' - else if (nodu .gt. 7) then - restq =sq//'ds' - else if (nodu .gt. 3) then - restq =sq//'qs' - else if (nodu .gt. 1) then - restq =sq//'hs' - else - restq =sq//'qqs' - lrest = 4 - end if -c if (2**log2(nodu) .ne. nodu) then -cc -cc One or two dots on rest -cc -c restq = restq(1:3)//'p' -c lrest = 4 -c if (2*nodu .gt. 3*2**log2(nodu)) then -cc -cc Double dotted rest -cc -c restq = restq(1:4)//'p' -c lrest = 5 -c end if -c end if - notexq = restq - lnote = lrest -c -c At this point notexq=restq,lnote=lrest are name of rest. Now raise if necc. -c - if (nole .ne. 0) then - if (abs(nole) .lt. 10) then - noteq = chax(48+abs(nole)) - lnoten = 1 - else - write(noteq(1:2),'(i2)')abs(nole) - lnoten = 2 - end if - if (nole .gt. 0) then - notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote' - else - notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote' - end if - lnote = 16+lnoten -c if (2**log2(nodu) .ne. nodu) then -cc -cc Have dot in raised rest. must put in hbox! -cc -c notexq = notexq(1:lnote)//sq//'hbox{' -c lnote = lnote+6 -c end if - notexq = notexq(1:lnote)//restq(1:lrest) - lnote = lnote+lrest -c if (2**log2(nodu) .ne. nodu) then -c notexq = notexq(1:lnote)//'}' -c lnote = lnote+1 -c end if - end if - if (2**log2(nodu) .ne. nodu) then -c -c Deal with dots (on rests shorter than half rest) -c - restq = sq//'pt' - lrest = 3 - if (2*nodu .gt. 3*2**log2(nodu)) then - restq = sq//'ppt' - lrest = 4 - end if - nole = nole+4 - raisedot = 0 -c -c Tweak dot positions for special cases -c - even = (mod(100+nole,2).eq.0) -c if (.not.even.and.nodu.gt.8.and. -c * (nole.lt.0.or.nole.gt.8)) then - if (.not.even .and. (nole.lt.0.or.nole.gt.8)) then - raisedot = 1 - end if - if (nole.ge.10 .or. nole.le.-1) then - write(numq,'(i2)')nole - restq = restq(1:lrest)//'{'//numq//'}' - lrest = lrest+4 - else - restq = restq(1:lrest)//chax(nole+48) - lrest = lrest+1 - end if - if (raisedot.gt.0) then - restq = sq//'raise'//sq//'internote'// - * sq//'hbox{'//restq(1:lrest)//'}' - lrest = lrest+23 - end if - - - - notexq = restq(1:lrest)//notexq(1:lnote) - lnote = lnote+lrest - end if - else -c -c Half rest or longer -c - if (nole .eq. 0) then -c -c Half or longer rest is not raised or lowered -c - if (nodu .le. 56) then - notexq =sq//'hpause' - lnote = 7 - else if (nodu .le. 112) then - if (.not.btest(islur(ivx,ip),19) .or. - * btest(irest(ivx,ip),25)) then - notexq = sq//'pause' - else - notexq = sq//'pausc' - end if - lnote = 6 - else - notexq =sq//'PAuse' - lnote = 6 - end if - if (2**log2(nodu) .ne. nodu) then -c -c Dotted rest, hpause or longer -c - notexq = notexq(1:lnote)//'p' - lnote = lnote+1 - if (2*nodu .gt. 3*2**log2(nodu)) then -c -c Double dotted long rest -c - notexq = notexq(1:lnote)//'p' - lnote = lnote+1 - end if - end if - else -c -c Raised or lowered half or whole rest -c - if (nodu .eq. 32) then - notexq = sq//'lifthpause' - lnote = 11 - else if (nodu .eq. 48) then - notexq = sq//'lifthpausep' - lnote = 12 - else if (nodu .eq. 56) then - notexq = sq//'lifthpausepp' - lnote = 13 - else if (nodu .eq. 64) then - notexq = sq//'liftpause' - lnote = 10 - else if (nodu .eq. 96) then - notexq = sq//'liftpausep' - lnote = 11 - else if (nodu .eq. 112) then - notexq = sq//'liftpausepp' - lnote = 12 - else if (nodu .eq. 128) then - notexq = sq//'liftPAuse' - lnote = 10 - else -c -c Assume dotted double whole rest -c - notexq = sq//'liftPAusep' - lnote = 11 - end if -c -c Set up height spec -c - nole = sign(abs(nole)/2,nole) - if (nole.le.9 .and. nole.ge.0) then - noteq = chax(48+nole) - lnoten = 1 - else - noteq = '{' - if (nole .ge. -9) then - write(noteq(2:3),'(i2)')nole - lnoten = 3 - else - write(noteq(2:4),'(i3)')nole - lnoten = 4 - end if - noteq = noteq(1:lnoten)//'}' - lnoten = lnoten+1 - end if - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+lnoten - end if - end if - end if - return - end - function ntindex(line,s2q,lenline) -c -c Returns index(line,s2q) if NOT in TeX string, 0 otherwise -c - character*(*) s2q,line - character*1 chax - logical intex - ndxs2 = index(line,s2q) - ndxbs = index(line,chax(92)) - if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then - ntindex = ndxs2 - else -c -c There are both bs and s2q, and bs is to the left of sq2. So check bs's to -c right of first: End is '\ ', start is ' \' -c - len = lenstr(line,lenline) - intex = .true. - do 1 ic = ndxbs+1 , len - if (ic .eq. ndxs2) then - if (intex) then - ntindex = 0 - ndxs2 = index(line(ic+1:len),s2q)+ic - else - ntindex = ndxs2 - return - end if - else if (intex .and. line(ic+1:ic+2).eq.chax(92)//' ') then - intex = .false. - else if (.not.intex .and. line(ic+1:ic+2).eq.' '//chax(92)) - * then - intex = .true. - end if -1 continue - end if - return - end - subroutine ntrbbb(n,char1q,ulqq,iv,notexq,lnote) -c -c This appends to notexq e.g. '\ibbbu1' -c - common /combbm/ isbbm - logical isbbm - character*79 notexq - character*1 char1q,ulqq,chax - character*4 tempq - if (n .ge. 5) isbbm = .true. - if (lnote .gt. 0) then - notexq = notexq(1:lnote)//chax(92)//char1q - else - notexq = chax(92)//char1q - end if - lnote = lnote+2 - do 3 im = 1 , n - notexq = notexq(1:lnote)//'b' - lnote = lnote+1 -3 continue -c -c add the number, 0 if 12 -c -c 5/25/08 Allow >12 -c -c call istring(mod(iv,12),tempq,len) - if (iv .lt. 24) then - call istring(iv,tempq,len) - else if (iv .eq. 24) then - tempq(1:1) = '0' - len = 1 - else - call printl('Sorry, too man open beams') - call stop1() - end if - notexq = notexq(1:lnote)//ulqq//tempq(1:len) - lnote = lnote+1+len - return - end - function numclef(clefq) -c -c Returns the number to be used as argument of \setclef (for MusiXTeX only) - character*1 clefq -c if (ichar(clefq) .lt. 55) then - if (ichar(clefq) .le. 55) then - numclef = ichar(clefq)-48 - if (numclef .eq. 7) numclef = 9 - else - numclef = index('tsmanrbxxf',clefq)-1 - end if - return - end - subroutine outbar(i,jlast) - character*1 chax - nfmt = log10(i+.5)+2 - if (jlast+5+nfmt .lt. 80) then - write(*,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i - write(15,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i - jlast = jlast+5+nfmt - else - write(*,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i - write(15,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i - jlast = 5+nfmt - end if - return - end - subroutine pmxa(basenameq,lbase,isfirst,nsyout,nbarss,optimize) -cccccccccccccccccccccccccccccccccccccccccccccccc -cc cc -cc Subroutine, combine with pmxb.for -cc -cccccccccccccccccccccccccccccccccccccccccccccccc -cc -cc Need to consider X spaces in xtuplets when getting poenom, and -cc maybe fbar? -cc mx06a -cc ID numbers for voices when number of voices is reduced. -cc -cc mx03a -cc account for new fracindent for new movements. -cc -cc Known changes since pmxa. Version 1.1b (see pmxb for longer list) -cc -cc Check ID codes for slurs. -cc Version 1.24 still does not have details for spacing/positioning -cc arpeggios if there are accidentals or shifted notes or crowded scores. -cc Fix problem in 1.22 with arpeggios across multi-line staves -cc Fix problem in 1.22 with flat key signatures -cc Read setup data as strings -cc Warning for octave designation plus +/- -cc Don't pause for volta warning, -cc Macros -cc Correct fsyst to account for transposition and key changes. -cc Check for nbars > nsyst -cc -ccccccccccccccccccccccccccccccccccc - parameter (nm=24,nkb=3999,nks=125,maxblks=4000) - logical loop,usefig,isfirst,optimize - character*65536 bufq - integer*2 lbuf(maxblks) - common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq - integer nn(nm),nodur(nm,200),ivxo(600),ipo(600), - * nnl(nm),itsofar(nm),nib(nm,15),lastbar(0:nks),nbarss(nks) - common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), - * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, - * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) - common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40), - * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), - * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), - * nistaff(0:40) - common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1, - * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS - real*4 elsk(nkb),celsk(0:nkb),elss(nks),to(600),tno(600) - character*128 lnholdq - character*44 basenameq - logical rest(nm,200),firstline,fbon,isvolt,iskchb,kchmid,ornrpt, - * stickyS - common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, - * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 - logical lastchar,newmeter,newmb(nkb),issegno,bottreb,isheadr, - * shifton,barend - common /a1ll/ iv,ivxo,ipo,to,tno,nnl,nv,ibar,mtrnuml, - * nodur,lenbar,iccount,nbars,itsofar,nib,nn, - * rest,lenbr0,lenbr1,firstline,newmeter - common /linecom/ elskb,tnminb(nkb) - common /cblock/ - * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, - * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh - common /cominbot/ inbothd - common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) - common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac - common /commus/ musize,whead20 - common /comeon/ eonk,ewmxk - logical mrecord,mplay,endmac,gotclef,cstuplet - logical novshrinktop,upslur,fontslur,WrotePsslurDefaults - common /comnvst/ novshrinktop,cstuplte - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - common /comligfont/ isligfont - logical isligfont - common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), - * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans - logical EarlyTransOn,LaterInstTrans - logical fulltrans - data wtimesig,wclef,wkeysig - * / 0.72 , 0.8 , 0.28 / - whead20 = 0.3 - if (.not.optimize) then - print* - print*,'Starting first PMX pass' - write(15,'(a)') ' Starting first PMX pass' - end if - if (isfirst) then - open(19,file='pmxaerr.dat') - write(19,'(i6)') 0 - close(19) - end if - if (.not.optimize) jprntb = 81 - macuse = 0 - ornrpt = .false. - stickyS = .false. - mrecord = .false. - mplay = .false. - lastchar = .false. - novshrinktop = .false. - cstuplet = .false. - fontslur = .true. - isligfont = .false. - fulltrans = .false. - do 42 ibarcnt = 1 , nkb - udsp(ibarcnt) = 0. - wminnh(ibarcnt) = -1. -42 continue -c -c Initialize input buffer -c - lenbuf0 = ipbuf - ipbuf = 0 - ilbuf = 1 - call g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, - * xmtrnum0,newkey(1),npages,nsyst,musize,bottreb) -c -c Set up list of instrument numbers (iv) -c - ivnow = 0 - do 13 instnow = 1 , noinst - do 14 iscount = 1 , nsperi(instnow) - ivnow = ivnow+1 - instno(ivnow) = instnow -14 continue -13 continue -c -c Save initial meter for midi -c - if (.not.isfirst .and. npages.eq.0) then - print*,'Sorry, must have npages>0 for optimization.' - call stop1() - end if - nsyout = nsyst -c -c isig1 will be changed in getnote if there is a transposition -c - isig1 = newkey(1) - if (npages .gt. nsyst) then - call printl('npages > nsyst in input. Please fix the input.') - call stop1() - end if -c -c fbar = afterruleskip/elemskip -c apt = width of small accidental + space in points (= 6 at 20pt) =wheadpt -c - fbar = 1. - wheadpt = whead20*musize - ifig = 0 - usefig = .true. - lenbeat = i1fnodur(mtrdenl,'x') - lenmult = 1 - if (mtrdenl .eq. 2) then - lenbeat = 16 - lenmult = 2 - end if - lenbr1 = lenmult*mtrnuml*lenbeat - lenbr0 = nint(lenmult*xmtrnum0*lenbeat) - mtrnuml = 0 - if (lenbr0 .ne. 0) then - ibaroff = 1 - lenbar = lenbr0 - else - ibaroff = 0 - lenbar = lenbr1 - end if - ibarcnt = 0 - nptr(1) = 1 - iccount = 128 - nmovbrk = 0 - nflb = 0 - nfpb = 0 - ipagfpb(0) = 1 - isysfpb(0) = 1 - ibarflb(0) = 1 - isysflb(0) = 1 - nistaff(0) = nv-1 -c -c Check for pmx.mod -c - linesinpmxmod = 0 -c line1pmxmod = ilbuf - call getpmxmod(.true.,' ') - if (.not.isfirst .and. linesinpmxmod .gt. 0) then - print*,'Sorry, cannot optimize if there is a pmx.mod file' - call stop1() - end if -c -c Initialize for loop over lines -c - nkeys = 1 - ibrkch(1) = 1 - mbrestsav = 0 - shifton = .false. - firstline = .true. - newmeter = .false. - ihead = 0 - isheadr = .false. - gotclef = .false. - idsig = 0 - iddot = 0 - fintstf = -1. - gintstf = 1.0 - listcresc = 0 - listdecresc = 0 -30 loop = .true. - iskchb = .false. - issegno = .false. - nbars = 0 - ibarmbr = 0 -3 do 4 iv = 1 , nv - nvmx(iv) = 1 - ivmx(iv,1) = iv - itsofar(iv) = 0 - nnl(iv) = 0 - do 5 j = 1 , 200 - rest(iv,j) = .false. - nacc(iv,j) = 0. -5 continue -4 continue - iv = 1 - ivx = 1 - fbon = .false. - barend = .false. - isvolt = .false. -2 if (loop) then -c -c Within this short loop, nv voices are filled up for the duration of a block. -c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) -c nodur(..),rest(..). nnl will later be -c increased and things slid around as accidental skips are added. -c - call g1etnote(loop,ifig,optimize,fulltrans) - if (lastchar) go to 20 - go to 2 - end if - if (mbrestsav .gt. 0) then - call printl(' ') - call printl( - * 'You must enter the same multibar rest in ALL parts') - call stop1() - end if - do 10 ibar = 1 , nbars - ibarcnt = ibarcnt+1 -c -c The following is just a signal to start a new bar when cataloging spaces -c for catspace(...) -c - nptr(ibarcnt+1) = nptr(ibarcnt) - newmb(ibarcnt) = .false. - if (newmeter.and.ibar.eq.1) newmb(ibarcnt) = .true. -c -c Above is only for spacing calcs later on. Remember new meter can only occur -c at START of a new input line (ibar = 1) -c - if (ibar .ne. ibarmbr) then - if (.not.optimize) call outbar(ibarcnt-ibaroff,jprntb) - else - if (.not.optimize) then - write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars', - * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1 - write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars', - * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1 - jprntb = 0 - end if - ibaroff = ibaroff-mbrest+1 - end if - if (firstline .and. lenbr0.ne.0) then - if (ibar .eq. 1) then - lenbar = lenbr0 - else - lenbar = lenbr1 - end if - end if - if (ibar .gt. 1) then -c -c For bars after first, slide all stuff down to beginning of arrays -c - do 11 iv = 1 , nv - do 11 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - ioff = nib(ivx,ibar-1) - do 12 ip = 1 , nib(ivx,ibar)-ioff - nodur(ivx,ip) = nodur(ivx,ip+ioff) - rest(ivx,ip) = rest(ivx,ip+ioff) - nacc(ivx,ip) = nacc(ivx,ip+ioff) -12 continue -11 continue - end if - do 67 iv = 1 , nv - do 67 kv = 1 , nvmx(iv) - ioff= 0 - if(ibar.gt.1)ioff = nib(ivmx(iv,kv),ibar-1) -67 continue - call makeabar() - elsk(ibarcnt) = elskb+fbar -10 continue - newmeter = .false. - firstline = .false. - go to 30 -20 continue -c -c Vertical analysis. -c - if (npages .eq. 0) then - if (nsyst .eq. 0) then - print*,'When npages=0, must set nsyst=bars/syst, not 0' - call stop1() - end if - nsyst = (ibarcnt-1)/nsyst+1 - if (nv .eq. 1) then - nsystpp = 12 - else if (nv .eq. 2) then - nsystpp = 7 - else if (nv .eq. 3) then - nsystpp = 5 - else if (nv .eq. 4) then - nsystpp = 3 - else if (nv .le. 7) then - nsystpp = 2 - else - nsystpp = 1 - end if - npages = (nsyst-1)/nsystpp+1 - end if -c -c Check nsyst vs ibarcnt -c - if (nsyst .gt. ibarcnt) then - print* - print*,'nsyst,ibarcnt:',nsyst,ibarcnt - print*,'There are more systems than bars.' - write(15,'(a,2i5)')' nsyst,ibarcnt:',nsyst,ibarcnt - write(15,'(a)')' There are more systems than bars.' - call stop1() - end if -c -c Set up dummy forced line & page breaks after last real one -c - nflb = nflb+1 - ibarflb(nflb) = ibarcnt+1 - isysflb(nflb) = nsyst+1 - nfpb = nfpb+1 - ipagfpb(nfpb) = npages+1 - isysfpb(nfpb) = nsyst+1 - heightil = ptheight*4./musize - open(12,status='SCRATCH') - write(12,'(a)')basenameq(1:lbase) - write(12,*)lbase -c -c Pass to pmxb the initial signature, including effect of transposition. -c - write(12,'(6f10.5/f10.5,3i5)')fbar,wheadpt,etait, - * etatc,etacs1,etatop,etabot,inbothd,inhnoh,isig1 - write(12,*)npages,widthpt,ptheight,nsyst - iflbnow = -1 - isysb4 = 0 - do 8 ifpb = 1 , nfpb -c -c Each time thru this loop is like a single score with several pages -c - npages = ipagfpb(ifpb)-ipagfpb(ifpb-1) - nsyst = isysfpb(ifpb)-isysfpb(ifpb-1) - nomnsystp = (nsyst-1)/npages+1 - nshort = nomnsystp*npages-nsyst - do 7 ipage = 1 , npages - nsystp = nomnsystp - if (ipage .le. nshort) nsystp = nsystp-1 -c -c Last system number on this page: - isysendpg = isysb4+nsystp - nintpg = 0 - do 15 isy = isysb4+1, isysendpg - if (isysflb(iflbnow+1) .eq. isy) iflbnow = iflbnow+1 - nintpg = nintpg+nistaff(iflbnow) -15 continue - xilfrac = 0. - xiltxt = 0. - if (ipage.eq.1 .and. ihead.gt.0) then -c -c Needn't zero out ihead after printing titles if we only allow titles at top? -c - if (iand(ihead,1) .eq. 1) then - xiltxt = xiltxt+hgtin*4/musize - xilfrac = xilfrac+etait - end if - if (iand(ihead,2) .eq. 2) then - xiltxt = xiltxt+hgtti*4/musize - xilfrac = xilfrac+etatc - end if - if (iand(ihead,4) .eq. 4) then - xiltxt = xiltxt+hgtco*4/musize - xilfrac = xilfrac+etacs1 - else -c -c Use double the title-composer space if there is no composer -c - xilfrac = xilfrac+etatc - end if - end if - D = xilfrac+nsystp-1+etatop+etabot -c C = nsystp*(nv-1) - C = nintpg -c xN = heightil - xiltxt - 4*nsystp*nv - (nsystp-1)*xilbn - xN = heightil - xiltxt - 4*(nintpg+nsystp) - (nsystp-1)*xilbn - if (bottreb) xN = xN-(nsystp-1)*xilbtc - if (ihead.eq.0 .and. isheadr) xN = xN - xilhdr - if (ifig .eq. 1) then - xN = xN - nsystp*xilfig - end if - glueil = (xN-b*C)/(D+a*C) - omegaG = (b*D+a*xN)/(D+a*C) -c -c G = \interlines between systems -c omega*G = \interlines between staves of the same system -c \interstaff = 4+omega*G -c C = total number of interstaff spaces in the page -c D = omega-indep factors for scalable height = nsy-1 (intersystem glue) -c + etatop + etabot + etatxt + -c N = scaleable height (\interlignes) = height - htext - staff heights - xil -c xil = extra interliges = (nsy-1)*xilbn + 10 if header and no titles -c + (nsy-1)*xiltcb for treble clef bottoms -c + nsy*xilfig for figures -c G = N/(D + omega * C) = glueil, (1) -c But (empirically) omega*G = a*G + b (2) -c with a=1.071 and b=2.714 -c Solving (1) and (2) gives -c G = (N-b*C)/(D+a*C) , omega*G = (b*D+a*N)/(D+a*C) -c Pass to pmxb omega*G (=\interstaff-4) -c (etatop,bot,it,tc,cx)*G as inputs to \titles -c -c glueil = (heightil-xiltxt-nsystp*(xil+4*nv)) -c * /(nsystp*(1+gfact*(nv-1))-1+etatop+etabot+xilfrac) -c xnsttop = glueil*etatop -c xintstaff = 4+gfact*glueil -c -c Only the first page will get local adjustment now if needed, others in pmxb -c - if (ifpb.eq.1 .and. ipage.eq.1 .and. fintstf.gt.0.) then - facins = fintstf - fintstf = -1. - else -c -c gintstf = 1.0 by default, but may be changed with AI<x> -c - facins = gintstf - end if - write(12,*)nsystp,max(0.,etatop*glueil),facins*(omegaG+4) - ihead = 0 - isheadr = .false. - isysb4 = isysendpg -7 continue -8 continue -c -c Done with vertical, now do horizontals -c - celsk(1) = elsk(1) - do 21 ibar = 2 , ibarcnt - celsk(ibar) = celsk(ibar-1)+elsk(ibar) -21 continue - lastbar(0) = 0 - ibar1 = 1 - wmins = -1. - iflb = 1 - imovbrk = 0 - ikey = 1 -c -c Return nsyst to its *total* value -c - nsyst = isysfpb(nfpb)-1 - do 22 isyst = 1 , nsyst - if (isyst .eq. isysflb(iflb)) iflb = iflb+1 - if (nmovbrk.gt.0 .and. imovbrk.lt.nmovbrk) then - if (isyst .eq. isysmb(imovbrk+1)) imovbrk = imovbrk+1 - end if - ibarb4 = lastbar(isyst-1) - if (isyst .eq. 1) then - if (isfirst) elsstarg = celsk(ibarflb(1)-1)/ - * (isysflb(1)-1-fracindent)*(1-fracindent) - celskb4 = 0. - else - celskb4 = celsk(ibarb4) -c -c Must dimension isysmb(0:*) just so I can execute this test! -c - if (isfirst) then - if (nmovbrk.gt.0 .and. isyst.eq.isysmb(imovbrk)) then -c -c First syst after forced line break. There may be indentation. -c - elsstarg = (celsk(ibarflb(iflb)-1)-celskb4) - * /(isysflb(iflb)-isyst-fracsys(imovbrk)) - * *(1-fracsys(imovbrk)) - else -c -c There is no indentation to deal with -c - elsstarg = (celsk(ibarflb(iflb)-1)-celskb4) - * /(isysflb(iflb)-isyst) - end if - end if - end if - if (isfirst) then - diff1 = abs(elsstarg-elsk(ibarb4+1)) - do 23 ibar = ibarb4+2 , ibarcnt - diff = elsstarg-(celsk(ibar)-celskb4) - if (abs(diff) .ge. diff1) go to 24 - diff1 = abs(diff) -23 continue -24 ibar = ibar-1 - lastbar(isyst) = ibar - nbarss(isyst) = ibar-ibarb4 - else -c -c nbarss is given as an input, must compute lastbar and ibar -c - lastbar(isyst) = nbarss(isyst)+ibarb4 - ibar = lastbar(isyst) - end if -c -c elss is # of elemskip in the syst. from notes & ars's, not ruleskips, ask's. -c - elss(isyst) = celsk(ibar)-celskb4 - write(12,'(i5)')lastbar(isyst-1)+1 -c -c Transposed sigs are isig1, newkey(2,3,...). -c - if (ikey .eq. 1) then - key1 = isig1 - else - key1 = newkey(ikey) - end if - fsyst = wclef+abs(key1)*wkeysig+2./musize - xelsk = 0. -1 if (ikey.lt.nkeys) then - if (ibrkch(ikey+1).le.lastbar(isyst)) then -c -c Add space for all key changes -c - ikey = ikey+1 - key2 = newkey(ikey) - naccs = max(abs(key2-key1),max(abs(key1),abs(key2))) - fsyst = fsyst+naccs*wkeysig -c -c Account for afterruleskips (fbar) -c - xelsk = xelsk+fbar/2 - if (ibrkch(ikey).lt.lastbar(isyst) .and. .not.kchmid(ikey)) - * xelsk = xelsk-1. - key1 = key2 - go to 1 - end if - end if -c -c Add extra fixed space for double bar -c - if (isyst .eq. nsyst) then - fsyst = fsyst+4.5/musize - end if -c -c Add extra fixed space for initial time signature -c - if (isyst .eq. 1) then - fsyst = fsyst+wtimesig - end if -c -c Add extra fixed space for time signature changes & user-defined spaces -c - do 26 ibars = ibarb4+1 , lastbar(isyst) - if (newmb(ibars)) fsyst = fsyst+wtimesig - fsyst = fsyst+udsp(ibars)/musize -26 continue - if (isyst .eq. 1) then - wdpt = widthpt*(1-fracindent) - else - if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and. - * isyst.eq.isysmb(imovbrk)) then - wdpt = widthpt*(1-fracsys(imovbrk)) - else - wdpt = widthpt - end if - end if - wsyspt = wdpt-fsyst*musize-0.4*nbarss(isyst) -c -c Checks for min spacing -c Get min allowable space -c - dtmin = 1000. - do 45 ibar = ibar1 , ibar1+nbarss(isyst)-1 - dtmin = min(dtmin,tnminb(ibar)) - if (wminnh(ibar).ge.0.) wmins = wminnh(ibar) -45 continue - if (wmins .lt. 0) wmins = 0.3 - wminpt = (1+wmins)*0.3*musize -c -c Find max duration & # of notes for this system -c - dtmax = 0. - nns = 0 - do 43 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1 - dtmax = max(dtmax,durb(iptr)) - nns = nns + nnpd(iptr) -43 continue - elmin0 = wsyspt*f1eon(dtmin)/(elss(isyst)+xelsk) - if (elmin0 .ge. wminpt) then -c -c Subtract out fbar stuff to keep old way of passing sumelsk to pmxb; -c there is no need to "flatten" -c - sumelsk = elss(isyst)-fbar*nbarss(isyst) - eonk = 0. - ewmxk = 1. - else - elmin1 = wsyspt/((fbar*nbarss(isyst)+xelsk)/f1eon(dtmax)+nns) - if (elmin1 .le. wminpt) then -c print* -c print*,'In system #',isyst,' cannot meet min. space rqmt' -c write(15,'(/a,i5,a)') -c * 'In system #',isyst,' cannot meet min. space rqmt' - eonk = 0.9 - else -c -c Find eonk by Newton method -c -c eonk = min(.9,(wminpt-elmin0)/(elmin1-elmin0)) - call findeonk(nptr(ibar1),nptr(ibar1+nbarss(isyst))-1, - * wsyspt/wminpt,fbar*nbarss(isyst)+xelsk,dtmin,dtmax, - * (wminpt-elmin0)/(elmin1-elmin0)) - eonk = min(.9,eonk) - end if - ewmxk = f1eon(dtmax)**eonk -c -c Recompute poenom! -c - sumelsk = 0 - do 44 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1 - sumelsk = sumelsk - * + nnpd(iptr)*sqzb(iptr)*feon(durb(iptr)/sqzb(iptr)) -44 continue - end if - poenom = wsyspt/(sumelsk+fbar*nbarss(isyst)+xelsk) -c -c Set fracindent for output: orig if isyst=1, fracsys(imovbrk) if movbrk, else 0 -c - if (isyst .gt. 0) then - if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and. - * isyst.eq.isysmb(imovbrk)) then - fracindent = fracsys(imovbrk) - else - fracindent = 0. - end if - end if - write(12,'(1pe12.5/i5,5e12.3)') poenom,nbarss(isyst), - * sumelsk,fsyst,fracindent,eonk,ewmxk - ibar1 = ibar1+nbarss(isyst) -22 continue - rewind(12) - open(13,status='SCRATCH') - write(13,'(i5)')ifig - rewind(13) - ilbuf = 1 - ipbuf = 0 - if (.not.optimize) then - write(*,'(/,a)')' Done with first pass' - print* - write(15,'(/,a)')' Done with first pass' - write(15,'()') - end if -c -c Following syntax is needed since pmxa is called with literal argument .false. -c - if (isfirst) isfirst = .false. - return - end - subroutine pmxb(inlast,poevec,ncalls,optimize) -cccccccccccccccccccccccccc -cc -cc To Do -cc -cc Resolve disagreement in final poe for 1st system, compared with *.mx2 -cc Shift slurs on right- or left-shifted main notes (2/7/99) -cc Various end-of-input-block repeat problems (ick142.pmx). -cc Force multiplicity for un-beamed xtups. -cc Clef change at end of piece -cc Global "A" option to maximize "X" at a given time tick. -cc Tighten test for end-of-bar hardspace, flgndv(ivx) due to right-shifted -cc note. See trubl18.pmx -cc Tab character as space. -cc Clef interference with second line of music. -cc Add space for interferences between *different* lines of music? -cc Shift arpeggios, both automatic and manual. -cc Different musicsize for different instruments. -cc Spacing checks for accid's on left-shifted chord notes -cc Spacing checks for double dots -cc Allow forced line breaks w/o setting nsyst. -cc Cresc-Decresc. (Enhance MusiXTeX first?) -cc Dynamic Marks. -cc Bug with Voltas at line end (MusiXTeX problem?). -cc Subtle bug w/ slur hgt over line brk, see trubl15.pmx -cc Stem-end slurs. -cc Allow units in indentation. -cc Make inline TeX more context sensitive. -cc Werner's 4/2/98 problem with "o?" -cc Scor2prt converts e.g. "r0+0" into "r0 0", which seems to be wrong. -cc converts e.g. "r2db" into "r2d", which might be wrong. -cc Werner's generalsignature problem with Key change and new transposition. -cc (wibug8.pmx) -cc Unequal xtuplets -cc Print both sets of bar #'s in tex file. -cc Make barlines invisible \def\xbar{\empty} , fix fbar. -cc Auto-tie slurs 'At' -cc Forced line break anywhere (e.g. at a mid-bar repeat). -cc Clef change at very start of file. -cc Tighten test for M as macro terminator. -cc Fix title so not separate limit on author length + composer length. -cc Arpeggios in xtups. -cc -cc mx10b -cc Option for instrument name at top center. Last item in P command: -cc P[n]c text is instrument name (use in parts) -cc P[n]cstuff text is stuff (up to 1st blank) -cc P[n]c"stuff with spaces" text is stuff with spaces -cc -cc Post version 1.43 -cc Reduced space rqmt for multiplicity-0 graces (no flag) -cc Removed last sepsym in centered whole-bar rests, fixes volta height bug. -cc -cc Version 1.43 -cc Fix spacing for end-of-line signature change. -cc Adjust left-shift of grace group for shifted accidentals. -cc Put in extra space for left-shifted accidentals. -cc Fix bug with dot-shift before accid-shift on chord note. -cc Space-check for right-shifted main notes. -cc Enable forcing stem direction of single notes in non-beamed xtups. -cc Disallow clef change after last note before end of input block (pmxa) -cc Print meter change before page break -cc increase length of strings for \titles macro -cc version 1.42 -cc Loosen up input syntax for "X" commands. Subroutine getx() -cc "B" and "P" in "X" commands -cc mx09b -cc Allow multiple rests at start of xtup -cc Add 64th rest -cc Fix xtup numbers over rests. (subroutine levrn) -cc Initialize notcrd=.false. every gulp. Avoids undefined state with e.g. -cc c za / ( c a ... -cc Allow double dots to be shifted. -cc Fix spacing with double dotted notes; permit splitting small note. -cc Fix \dotted printout so it works with old compiler -cc mx08b -cc Automatic spaces if needed for shifted accidentals. -cc Some Dynamics -cc Increase accid. horiz. shift resolution to .o5 (use one more bit in nacc) -cc version 1.41 -cc Allow ":" as last char of path name -cc Dotted slurs "sb" -cc Continue bar numbering at movement break "L[integer]Mc" -cc mx07b -cc Whole-bar rests with double lines of music. Fixed all options ? -cc Shift accidentals, either [+|-][integer][+|-][number] or [<|>][number]. -cc Option to suppress centering full-bar rests. "o" -cc mx06b -cc Shift accid on left-shifted chord note. -cc Rest as first note of xtup. -cc Wrong slopes with small widths. Scale slfac1 by widthpt_default/widthpt -cc Allow Rb for single bar at movemnet break or end of piece. (islur(25)) -cc Change # of inst at a movement break. noinst is total # and must be used -cc in 1st movement. ninow is current. nspern(1,...,ninow) is current -cc staves/inst, nsperi(1,...,noinst) is original. rename tells whether to -cc reprint names in parindent at a movement break. Default is .false. -cc unless ninow changes, then .true. But can force either with r+/- as -cc option in 'M' -cc mx04b -cc Double-dotted notes, separate+beamed, main+chord, still no extra space. -cc ??? Don't shift slur ends on whole notes. -cc (pmxa) Write line number of error in pmxaerr.dat -cc mx02b -cc Admit "RD" before "/" (search for "rptfq2:" ) -cc In doslur, for multi-line staves, single notes, check forced stem dir'n -cc before setting stemup (used to set horiz offset). -ccccccccccccccccccccccccccccccc - parameter (nm=24,nks=125,mv=24576,maxblks=4000) -c -c FYI /all/ differs in appearance in function ncmid -c - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - common /comipl2/ ipl2(nm,200) -ccccccccccccc -cc islur cc -ccccccccccccc -c bit meaning -c 0 slur activity on this note -c 1 t-slur here. -c 2 force 0-slope beam starting on this note -c 3 Double dotted note! -c 4 grace before main note -c 5 left repeat -c 6 right repeat -c 7 start Volta -c 8 doublebar -c 9 end Volta -c 10 on=>endvoltabox -c 11 on=>clefchange -c 12-14 0=>treble, ... , 6=>bass -c 15 on=> start new block for clef change (maybe diff. voice) -c 16 literal TeX string -c 17 1=up, 0=down stem for single note (override) See bit 30! -c 18 if on, prohibit beaming -c 19 if on, full bar rest as pause -c 20 Beam multiplicity down-up -c 21 Forced multiplicity for any beam including xtups -c 22-24 Value of forced multiplicity -c 25 single barline at movement break -c 26 doubleBAR (see bits 5,6,8) -c 27-28 Forced beam fine-tune height (1 to 3) -c 29 Blank rest -c 30 If on, get stem dir'n from bit 17 -c 31 If on, suppress printing number with xtuplet starting here -ccccccccccccc -cc ipl cc -ccccccccccccc -cc 0-7 Location in list [0,200] -c 0-7 Unused -c 8 left offset main note one headwidth -c 9 right offset main note one headwidth -c 10 chord present? -c 11-16 Forced beam height adjustment (-30 to +30) -c 17-22 Forced beam slope adjustment (-30 to +30) -c 23-26 Slur index for Way-after grace. Inserted when slur is started. -cc 27 Unused? -c 27 5th bit for slur index for Way-after grace (100712) -c 28 key change: only in voice 1 -c 29 Grace after main note. (Type A) -c 30 In forced beam. Signals need to check beam heights -c 31 Grace way after main note. (stretch to next note, type W) -ccccccccccccc -cc iornq cc -ccccccccccccc -c 0 Ornament "(". Was user-defined horizontal slur shift on this note -c until 9/24/97; changed that to irest(21) -c 1-13 stmgx+Tupf._) -c 14 Down fermata, was F -c 15 Trill w/o "tr", was U -c 16-18 Editorial s,f,n -c 19-20 >^ -c 21 "?" for editorial accid, w/ or w/o s,f,n -c 22 Set if ihornb governs ornament height. Same in icrdorn. -c 23 Set in getorn if ANY note at time of this main note has ornament. -c This is ONLY used in beamstrt to signal whether to do more -c tests for whether ihornb is needed. (ihornb is only needed -c if nonchord+upbm, chord+upbm+top_note, chord+dnbm+bot_note) -c (7/1/00)Also set if any dynamic, as ihornb will be needed when dnbm. -c 24 Slur on after or way-after grace. Use as signal to START slur. -c 25 Tweak orn ht. Same in icrdorn for chord note -c 26 Insert user-defined space before this note (was 22) -c 27 Arpeggio stop or start (if 2 at same time), or all-in-this-chord -c 28 caesura or breath -c 29 blank barline (must be iv=1) (would have used islur but no room) -c 30 "Look-left" option for keyboard rest -c 31 Set if any note (main or chord) has cautionary accid, for space checks -ccccccccccccc -cc irest cc -ccccccccccccc -c 0 rest=1, no rest = 0 -c 1 There will be a vertical shift for number of this xtup -c 2-6 Height shift, 1 => -15, 31 => +15 Indicate by +/- [n] after 'n' -c 7 There is a horizontal shift for xtup number -c 9-13 Horiz shift, 1=>-1.5, ... , 31=>+1.5 -c 14 Flip up/down-ness of xtup number -c 15 Single-voice, single note shift X(...)[p]S -c 16 Start single-voice, multinote shift with this note X(...)[p]: -c 17 End single-voice, multinote shift after this note. Enter symbol -c after note. X: -c 18 User-defined hardspace after last note of bar, *after* this note. -c Value still stored in udoff(ivx,nudoff(ivx)), not with other -c hardspaces in udsp, to avoid confusion with time checks. -c 19 Move the dot. Data stored in ndotmv,updot,rtdot -c 20 Set if right-shifted main or chord note here. Use for space checks. -c 21 User-defined hardspace in xtup -c 22 User-defined slur shift horizontal slur shift. -c 23 Set on last note before staff-jumping a beam. -c 24 Set on first note after staff-jumping a beam -c 25 Suppress rest centering. "ro" -c 26 Dynamic on this note -c 27 Set if left-shifted main or chord note here. Use for space checks. -c 28 Set if xtup starts on this note. -c 29 Set on lowest-voice note at same time as 1st note after jump-beam. -c 30 Set on note after end of jump-beam segment, to force new note group -c 31 Flag for cautionary accidental -ccccccccccccc -cc nacc cc -ccccccccccccc -c 0-1 0=no accid, 1=fl, 2=sh, 3=na -c 2 double -c 3 big -c 4-9 vertshift-32 -c 10-16 20*(horiz. shift + 5.35) (Recentered ver 2.32) -c 17 Midi-only accidental -c 18 2:1 xtup -c 19 Together with nacc(18), increase multiplicity by 1 and dot 1st note. -c 20 Set on last note of each seg except last seg of single-slope beam. -c 21 Set on 1st note of each seg except 1st seg of single-slope beam. -c 22-26 If .ne.0, printed xtup number for xtup starting on this note. -c 27 Set for dotted xtup note. Mult dur by 1.5, mult next by .5 & increase -c multiplicity by 1 -c 28 Set on main note of chord if accidentals are ordered. -c 29 Tag for chordal accidental shift...means add to autoshifts. -c 30-31 Set 30|31 if main note in a chord is part of a 2nd and needs to be shifted. -c If upstem|downstem, main is upper|lower member of 2nd -c Action is to interchange pitches only when notes are placed. -ccccccccccccc -cc mult cc -ccccccccccccc -c 0-3 Multiplicity+8 (mult= # of flags) -c 4 Set if slope adjustment for xtup bracket -c 5-9 16+slope adjustment -c 27 Stemlength override -c 28-30 New stem length. -ccccccccccccc -cc isdat1 cc -ccccccccccccc -c 13-17 iv -c 3-10 ip -c 11 start/stop switch -c 12 kv-1 -c 19-25 ichar(code$) -c 26 force direction? -c 27 forced dir'n = up if on, set in sslur; also -c final direction, set in doslur when beam is started, used on term. -c 28-31 ndxslur, set in doslur when beam is started, used on term. -ccccccccccccc -cc isdat2 cc -ccccccccccccc -c 0 Chord switch. Not set on main note. -c 1-2 left/right notehead shift. Set only for chord note. -c 3 tie positioning -c 4 dotted slur -c 6-11 voff1 1-63 => -31...+31 -c 12-18 hoff1 1-127 => -6.3...+6.3 -c 19-25 nolev -c 26 \sluradjust (p+s) -c 27 \nosluradjust (p-s) -c 28 \tieadjust (p+t) -c 29 \notieadjust (p-t) -ccccccccccccc -cc isdat3 cc -ccccccccccccc -c 0 set if midslur (at least one argument) -c 1 set if curve (2 more args) -c 2-7 32+first arg (height correction) (1st arg may be negative) -c 8-10 second arg (initial slope) -c 11-13 third arg (closing slope) -c 14-21 tie level for use in LineBreakTies -c 22-29 ncm for use in LineBreakTies -ccccccccccccc -cc isdat4 cc Set these all at turn-on using s option -ccccccccccccc -c 0-5 Linebreak seg 1 voff 1-63 => -31...+31 -c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 -c 16-21 Linebreak seg 2 voff 1-63 => -31...+31 -c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 -ccccccccccccc -c icrdat c -ccccccccccccc -c 0-7 ip within voice -c 8-11 ivx (together with 28th bit) -c 12-18 note level -c 19 accidental? -c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) -c 23 shift left -c 24 shift right -c 25 arpeggio start or stop -c 26 flag for moved dot (here, not icrdot, since this is always reset!) -c 27 Midi-only accidental -c 28 (6/27/10) 5th bit for ivx, to allow up to 24 voices -c 29 Tag for accidental shift...means add to autoshifts. -c 31 Flag for cautionary accidental on chord note -ccccccccccccc -c icrdot c: -ccccccccccccc -c 0-6 10*abs(vertical dot shift in \internote) + 64 -c 7-13 10*abs(horizontal dot shift in \internote) + 64 -c 14-19 vert accidental shift-32 -c 20-26 20*(horiz accidental shift+3.2) -c 27-29 top-down level rank of chord note w/accid. Set in crdaccs. -c -c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. -c -cccccccccccccccccccccccccccccccc - character*65536 bufq - integer*2 lbuf(maxblks) - common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq - character*10 figq - character*1 ulq,sepsymq,sq,chax - logical beamon,firstgulp,figbass,figchk, - * isfig,rptnd1,rptprev - logical loop,lastchar,slint,svolta,evolta,onvolt, - * cwrest(nm),islast,inlast,optimize - integer istop(80),numbms(nm),istart(80) - real*4 xnsttop(40),xintstaff(40),hesk(23),hpts(23),poevec(nks), - * tstart(80),squez(80) - character*1 clefq(nm),ulfbq,rptfq1,rptfq2,charq - character*79 notexq,inameq - character*40 pathnameq - character*44 basenameq - character*24 fmtq - character*20 voltxtq - character*120 instrq,titleq,compoq - common /comlast/ islast,usevshrink - logical usevshrink,stickyS,OptLineBreakTies,autofbon - common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 - common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, - * inhead - common /cominbot/ inbothd - common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), - * fullsize(nm),ivxfig2 - common /comnsp/ space(80),nb,prevtn(nm), - * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) - common /comstart/ facmtr - common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, - * tautofb,autofbon,t1autofb - common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, - * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, - * rptprev,equalize,rptfq1,rptfq2 - common /combeam/ ibmtyp - common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd, - * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage, - * OptLineBreakTies,HeaderSpecial - common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, - * isig,lastisig,fracindent,widthpt,height,idsig, - * lnam(nm),inameq(nm) - common /comas1/ naskb,task(40),wask(40),elask(40) - common /comas2/ nasksys,wasksys(800),elasksys(800) - common /comas3/ ask(2500),iask,topmods - common /comask/ bar1syst,fixednew,scaldold, - * wheadpt,fbar,poenom - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - common /comsln/ is1n1,is2n1,irzbnd,isnx - common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, - * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, - * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, - * graspace(37), - * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), - * naccg(74),voltxtq(6),litq(83) - logical upg,slurg,slashg,fbon,ornrpt,shifton,isbjmp,notcrd,was2, - * isbj2,fontslur,WrotePsslurDefaults,HeaderSpecial - common /comivxudorn/ivxudorn(63) - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - character*128 litq,lnholdq - logical upslur,bar1syst,vshrink,lrpt,rrpt,lrptpend, - * ispoi,bcspec,topmods,headlog,clchb,clchv(nm),flgndb, - * btest,sluron,setis,nobar1 - common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), - * ndotmv(nm),updot(nm,20),rtdot(nm,20) - common /compoi/ ispoi - common /combc/ bcspec - common /comeon/ eonk,ewmxk - common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, - * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, - * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, - * rtshfac - common /comhsp/ hpttot(176) - common /combmh/ bmhgt,clefend - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac - common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) - common /strtmid/ ihnum3,flipend(nm),ixrest(nm) - common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), - * xinsnow,lowdot - common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) - common /commus/ musize,whead20 - common /comtol/ tol - common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), - * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), - * idynda2(99),levhssav(nm),listcresc,listdecresc - character*128 txtdynq - logical mrecord,mplay,endmac,flipend,istype0,lowdot,rename,ispstie - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc,equalize, - * ismbr,putmbr - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - common /comcb/ nbc,ibcdata(36) - common /comclefq/ clefq - common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), - * ArpShift(20) - common /comligfont/ isligfont - logical isligfont - common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), - * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans - logical EarlyTransOn,LaterInstTrans - common /combibarcnt/ ibarcnt - if (.not.optimize) then - print* - print*,'Starting second PMX pass' - print* - write(15,'(a)')'Starting second PMX pass' - end if - ncalls = ncalls+1 - islast = inlast - macuse = 0 - isyscnt = 0 - stemmax = 8.2 - stemmin = 3.9 - stemlen = 6.0 - sq = chax(92) - bcspec = .true. - topmods = .false. - ismbr = .false. - read(12,'(a)')basenameq - read(12,*)lbase - read(12,*)fbar,wheadpt,etait,etatc,etacs1,etatop, - * etabot,inbothd,inhnoh,isig - ilbuf = 1 - ipbuf = 0 - call getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0, - * npages,nsyst,musicsize,fracindent,istype0,inameq, - * clefq,sepsymq,pathnameq,lpath,isig0) - if (ismidi) then -c -c Initial key signature and meter for pickup bar -c - call midievent('k',isig,0) - if (xmtrnum0 .gt. tol) then -c -c We have a pickup. Some tricky stuff to get a meter: -c - xntrial = xmtrnum0 - do 5 ip2 = 0 , 5 - if (abs(mod(xntrial,1.)) .lt. tol) go to 6 - xntrial = xntrial*2 -5 continue - print*,'Problem finding meter for pickup bar' - xntrial = 1. - ip2 = 0 -6 continue - call midievent('m',nint(xntrial),2**ip2*mtrdenl) - else -c -c No pickup, enter the starting meter -c - call midievent('m',mtrnuml,mtrdenl) - end if - end if -c -c Set musicsize from value passed in common, due to possible reset by S[n]m16 -c - musicsize = musize - read(12,*)npages,widthpt,height,nsyst, - * (nsystp(ipa),xnsttop(ipa),xintstaff(ipa),ipa=1,npages),iauto -c -c If default width ever changes, must adjust this stmt. -c - slfac1 = 0.00569*524./widthpt - figbass = .false. - read(13,*)ifig - if (ifig .eq. 1) then - figbass = .true. - open(14,status='SCRATCH') - write(14,'(a)')sq//'def'//sq//'fixdrop{'//sq//'advance'//sq// - * 'sysno by 1'//sq//'ifcase'//sq//'sysno%' - end if - lastchar = .false. - ibcoff = 0 - if (xmtrnum0 .gt. 0.) ibcoff = -1 - open(11,status='SCRATCH') -c -c vshrink for the first page is calculated in topfile, -c and if true set interstaff=10. vshrink affects Titles. -c Must also save vshrink for page ending. -c - call topfile(basenameq,lbase,nv,clefq,noinst,musicsize, - * xintstaff(1),mtrnmp,mtrdnp,vshrink,fbar,fontslur) -c -c ninow is working value of # of instruments. noinst is max #, and # at start. -c - ninow = noinst -c -c Save original printed meter in case movement breaks -c - movnmp = mtrnmp - movdnp = mtrdnp -c - if (islast .and. figbass .and. musicsize.eq.16) - * write(11,'(a)')sq//'def'//sq//'figfont{'//sq//'eightrm}%' -c - if (islast .and. isligfont) then - if (musicsize .eq. 16) then - write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 8pt%' - else - write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 10pt%' - end if - end if - lenbeat = ifnodur(mtrdenl,'x') - if (mtrdenl .eq. 2) lenbeat = 16 - lenb1 = mtrnuml*lenbeat - if (mtrdenl .eq. 2) lenb1 = lenb1*2 - call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) - lenb0 = nint(xmtrnum0*lenbeat) - if (mtrdenl .eq. 2) lenb0 = lenb0*2 - if (lenb0 .ne. 0) then - if (islast) write(11,'(a)')sq//'advance'//sq//'barno by -1' - lenbar = lenb0 - else - lenbar = lenb1 - end if -c -c Initialize full-program variables -c - fixednew = 0. - scaldold = 0. - fintstf = -1. - gintstf = 1. - nasksys = 0 - ibarcnt = 0 - iline = 0 - movbrk = 0 - isystpg = 0 - ipage = 1 - iccount = 128 - iask = 0 - nhstot = 0 - nb = 1 - if (.not.optimize) jprntb = 81 - idsig = 0 -c -c Next 5 are raise-barno parameters. irzbnd is integer part of default level. -c - irzbnd = 3 - if (isig.eq.3 .and. clefq(nv).eq.'t') irzbnd = 4 - is1n1 = 0 - isnx = 0 - SlurCurve = 0. -c -c 111109 Made global rather than per gulp -c - ndyn = 0 - ispoi = .false. - slint = .false. - lrptpend = .false. - rptnd1 = .false. - rptfq2 = 'E' - rptprev = .false. - onvolt = .false. - flgndb = .false. - fbon = .false. - shifton = .false. - ornrpt = .false. - setis = .false. - lowdot = .false. - rename = .false. - nobar1 = .false. - equalize = .false. - usevshrink = .true. - WrotePsslurDefaults = .false. - OptLineBreakTies = .false. - HeaderSpecial = .false. -c -c vshrink is initialized in topfile -c - stickyS = .false. -c -c ixrest = 1 or 2 if xtup has started with a rest -c - do 1 ivx = 1 , nm - ixrest(ivx) = 0 - fullsize(ivx) = 1. -c -c Set legacy note level to middle c as default -c - ndlev(ivx,1) = 29 - ndlev(ivx,2) = 29 -1 continue - npreslur = 0 - nhssys = 0 - listslur = 0 - do 31 i = 1 , 202 - isdat1(i) = 0 - isdat2(i) = 0 -31 continue - nsdat = 0 -c -c Initialize flag for figures in any other voice than 1 -c - ivxfig2 = 0 -c -c Initialize for loop over gulps -c - firstgulp = .true. -c -c Start a gulp -c -30 loop = .true. - notcrd = .true. - isbjmp = .false. - isbj2 = .false. - autofbon = .false. - tautofb = 0. - nbars = 0 - nfigs(1) = 0 - nfigs(2) = 0 - ngrace = 0 - ntrill = 0 - ncrd = 0 - nudorn = 0 - nlit = 0 - nvolt = 0 - ibarmbr = 0 - nudsp = 0 -c ndyn = 0 ! 111109 - ntxtdyn = 0 - nbc = 0 - NumArpShift = 0 - do 3 i = 1 , 37 - graspace(i) = 0. -3 continue -c -c Now initialize up to nv. Do it in getnote as r'qd for 2nd voices per syst. -c and also if nv increases in an 'M' directive. -c - do 4 iv = 1 , nv - call newvoice(iv,clefq(iv),.false.) -4 continue -c -c Check if endsymbol was set earlier -c - if (rptnd1) then - rptnd1 = .false. - rptfq2 = rptfq1 - else -c -c Only use if movbrk>0, to signal default ('RD') -c - rptfq2 = 'E' - end if - iv = 1 - ivx = 1 -2 if (loop) then -c -c Within this loop, nv voices are filled up for the duration of the block. -c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) -c nolev(nv,nnl(nv)),nodur(..),accq(..),irest(..). -c nbars is for this input block. -c Only at the beginning of an input block will there be a possible mtr change, -c signalled by a nonzero mtrnuml. (which will be re-zeroed right after change) -c - call getnote(loop) - if (lastchar) go to 40 - go to 2 - end if -c -c Finished an input block (gulp). -c - if (ismidi) then -c -c Put rests into midi array for 2nd lines that were not used in this gulp. -c - do 60 iv = 1 , nv - if (twoline(iv) .and. nvmx(iv).eq.1) then - if (firstgulp .and. lenb0.ne.0) then - call addmidi(midchan(iv,2),0,0,0, - * (nbars-1.)*lenbar+lenb0,.true.,.false.) - else - call addmidi(midchan(iv,2),0,0,0,1.*nbars*lenbar,.true., - * .false.) - end if - end if -60 continue - end if - nvolt = 0 - do 28 iv = 1 , nm - nudoff(iv) = 0 - ndotmv(iv) = 0 -28 continue -c -c Put stuff at top of p.1. Must wait until now to have read title info. -c - if (ibarcnt .eq. 0) then - call puttitle(inhnoh,xnsttop(ipage), - * etatop,sq,etait,etatc,etacs1,nv,vshrink,sepsymq) - if (HeaderSpecial) -c -c Write special header for first page -c - * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%' - end if - do 10 ibar = 1 , nbars - ibarcnt = ibarcnt+1 - bar1syst = ibarcnt .eq. iauto - ndig = max(0,int(log10(.001+ibarcnt+ibcoff))) - if (islast) - * write(11,'(a11,i'//chax(50+ndig)//')') - * '% Bar count',ibarcnt+ibcoff - if (ibar .ne. ibarmbr) then - if (.not.optimize) call outbar(ibarcnt+ibcoff,jprntb) - else - if (.not.optimize) then - write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars', - * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1 - write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars', - * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1 - jprntb = 0 - end if - ibcoff = ibcoff+mbrest-1 - if (ibar.eq.1 .and. firstgulp .and. - * .not.btest(islur(1,1),5)) xb4mbr = facmtr*musicsize -c -c The above may be he only case where the space-before option is used in \mbrest -c - end if -c -c Move the read to after end-of-bar hardspace checks, so we get right poenom -c at end of a line. -c if (bar1syst) read(12,*) poenom -c -c Check for clef at start of bar. No slide yet. Also flags at end of prev. -c bar. This block is run at the start of every bar. May fail for flag at -c end of last bar. To account for necc. hardspaces, compute and store -c nhssys = # of hard spaces for this system -c hesk(nhssys) = elemskips avialable -c hpts(nhssys) = hard points needed, including notehead -c Here, merely insert placeholder into output. Later, when poe is computed, -c compute additional pts and store them in hpttot(1...nhstot). Finally in -c subroutine askfig, write true pts where placeholders are. -c - ioff = 0 - if (ibar .gt. 1) ioff = nib(1,ibar-1) - clchb = btest(islur(1,ioff+1),15) - putmbr = .false. - if (ismbr) then - if (clchb) then -c -c Clef change and multi-bar rest coming up. Kluge to get space at end of rest. -c - write(11,'(a)')sq//'let'//sq//'mbrt'//sq//'mbrest' - * //sq//'def'//sq//'mbrest#1#2#3{%' - write(11,'(a14,f4.1,a)')sq//'mbrt{#1}{#2}{',musicsize*.55, - * '}'//sq//'global'//sq//'let'//sq//'mbrest'//sq//'mbrt}%' - end if - ismbr = .false. - putmbr = .true. - end if - if (ibar .eq. ibarmbr) ismbr = .true. -c -c Set flag here so at start of next bar, if there's a clef change, can add space -c after the mbr with the above kluge -c - if (.not.(clchb .or. flgndb)) go to 23 -c -c Must check available space -c - ptsndb = 0. -c -c Zero out block signal -c - if (clchb) islur(1,ioff+1) = ibclr(islur(1,ioff+1),15) -c -c In this loop, we determine how much hardspace is needed (if any) -c 9/7/97 Note that for last bar in input block, if number of lines of -c music decreases in new block, highest numbered ones won't be checked -c since the loop below covers the new nvmx(iv), not necessarily the old -c one. -c 4/18/98 Apparently nmxsav was a solution to the above problem -c - do 16 iv = 1 , nv - do 16 kv = 1 , nvmxsav(iv) - ivx = ivmxsav(iv,kv) - ptsndv = flgndv(ivx)*wheadpt - ioff = 0 - if (ibar .gt. 1) then - ioff = nib(ivx,ibar-1) - ip = ioff - if (ibar.gt.2) ip = ioff-nib(ivx,ibar-2) -c prevtn(ivx) = tnote(iand(ipl(ivx,ip),255)) - prevtn(ivx) = tnote(ipl2(ivx,ip)) -c -c If ibar=1 (1st bar in input block), prevtn(ivx) was set at end of makeabar. -c - end if -c -c Only allow clef changes when ivx <= nv -c - if (ivx .le. nv) then - clchv(iv) = clchb .and. btest(islur(iv,ioff+1),11) - if (clchv(iv)) then -c -c Clef change in this voice. Turn off signal. Get space avail. -c - islur(iv,ioff+1) = ibclr(islur(iv,ioff+1),11) - if (abs(prevtn(iv)-space(nb)).lt.tol) ptsndv = - * ptsndv+clefend*wheadpt - end if - end if - ptsndb = max(ptsndb,ptsndv+wheadpt*xspfac) -16 continue -c -c ???? where is nb set??? nb probably in left over from makeabar -c - esk = feon(space(nb)*squez(nb)) - ptsdflt = esk*poenom-wheadpt -c if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0) then - if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0 - * .and. .not.putmbr) then -c -c Must ADD hardspace! So put in a placeholder, and store params for later. -c - if (islast) write(11,'(a)')sq//'xardspace{ pt}%' - nhssys = nhssys+1 - if (ptsndb-ptsdflt .gt. ptsgnd-poenom*eskgnd) then - hesk(nhssys) = esk - hpts(nhssys) = ptsndb+wheadpt - else - hesk(nhssys) = eskgnd - hpts(nhssys) = ptsgnd+wheadpt - end if - fixednew = fixednew+hpts(nhssys) - scaldold = scaldold+hesk(nhssys) - end if - if (clchb) then - do 17 iv = 1 , nv - if (clchv(iv)) then - notexq = sq//'znotes' - lnote = 7 - do 24 iiv = 2 , iv - notexq = notexq(1:lnote)//sepsymq(iiv-1) - lnote = lnote+1 -24 continue -c -c Recompute ioff since it will vary from voice to voice -c - if (ibar .eq. 1) then - ioff = 0 - else - ioff = nib(iv,ibar-1) - end if -c -c Must call clefsym to get nclef, even if there is a movement break -c - call clefsym(islur(iv,ioff+1),fmtq,lclef,nclef) - if (movbrk.eq.0 .and. - * islast) - * write(11,'(a)')notexq(1:lnote)//fmtq(1:lclef)//sq//'en%' - call wsclef(iv,ninow,clefq,nclef) - end if -17 continue - if (islast) write(11,'(a)')sq//'pmxnewclefs' - end if -23 continue -c -c End of loop for end-of-bar hardspaces and non-movbrk clef symbol. -c - if (bar1syst) then - read(12,*) poenom - end if -c -c Repeat symbols. Haven't slid down yet, so use islur(1,nib(1,ibar-1)+1) -c - if (ibar .eq. 1) then - islnow = islur(1,1) - iornqnow = iornq(1,1) - else - islnow = islur(1,nib(1,ibar-1)+1) - iornqnow = iornq(1,nib(1,ibar-1)+1) - end if -c -c Check for R-symbols set at end of prior input block -c - if (movbrk.eq.0 .and. rptfq2.ne.'E') then - if (rptfq2 .eq. 'D') then - islnow = ibset(islnow,26) - else if (rptfq2 .eq. 'r') then - islnow = ibset(islnow,6) - else if (rptfq2 .eq. 'd') then - islnow = ibset(islnow,8) - else if (rptfq2 .eq. 'b') then - islnow = ibset(islnow,25) - else - print* - print*,'Illegal symbol with "R" at end of input block:', - * rptfq2 - call stop1() - end if - rptfq2 = 'E' - end if - if (iand(islnow,352) .ne. 0) then -c -c Bit 5(lrpt), 6(rrpt), or 8(doublebar) has been set -c - lrpt = btest(islnow,5) - rrpt = btest(islnow,6) - lrptpend = lrpt.and.bar1syst - if (lrpt .and. .not.lrptpend) then - if (rrpt) then - if (islast) write(11,'(a)')sq//'setleftrightrepeat' - fixednew = fixednew+wheadpt*lrrptfac-0.4 - else - if (islast) write(11,'(a)')sq//'setleftrepeat' - fixednew = fixednew+wheadpt*rptfac-0.4 - end if - else if (rrpt) then - if (islast) write(11,'(a)')sq//'setrightrepeat' - fixednew = fixednew+wheadpt*rptfac-0.4 - else if (btest(islnow,8)) then - if (islast) write(11,'(a)')sq//'setdoublebar' - fixednew = fixednew+wheadpt*dbarfac-0.4 - end if - else if (btest(islnow,26)) then -c -c doubleBAR -c - if (islast) write(11,'(a)')sq//'setdoubleBAR' - fixednew = fixednew+wheadpt*ddbarfac-0.4 - else if (btest(iornqnow,29)) then -c -c no bar line -c -c-- if (islast) write(11,'(a)')sq//'setzalaligne' -c++ - if (islast) then - if (movbrk .eq. 0) then - write(11,'(a)')sq//'setzalaligne' - else -c -c Encountered "Rz" at start of input block at start of new movement, Must -c use newmovement macro with arg 4 rather than setzalaligne, since former -c already redefines stoppiece. -c - rptfq2 = 'z' - end if - end if -c++ - fixednew = fixednew-0.4 - end if -c -c 1st and 2nd endings -c - svolta = btest(islnow,7) - evolta = btest(islnow,9) - if (evolta) then - if (btest(islnow,10)) then - if (islast) write(11,'(a)')sq//'endvoltabox' - else - if (islast) write(11,'(a)')sq//'endvolta' - end if - onvolt = .false. - end if - if (svolta) then - nvolt = nvolt+1 - lvoltxt = index(voltxtq(nvolt),' ')-1 - if (lvoltxt .eq. 1) then - if (islast) write(11,'(a)')sq//'Setvolta' - * //voltxtq(nvolt)(1:1)//'%' - else - if (islast) write(11,'(a)')sq//'Setvolta'//'{'// - * voltxtq(nvolt)(1:lvoltxt)//'}%' - end if - onvolt = .true. - end if - if (ibar .gt. 1) then - ipnow = nib(1,ibar-1)+1 - else - ipnow = 1 - end if - iplnow = ipl(1,ipnow) - if (bar1syst) then -c -c If listslur>0, then there is at least one slur or tie carried over the break -c - ispstie = .false. - if (OptLineBreakTies .and. .not.fontslur .and. listslur.ne.0 - * .and. islast) - * call LineBreakTies(isdat1,isdat2,isdat3,isdat4, nsdat, - * ispstie,sepsymq) - iline = iline+1 -c -c End an old system, Start a new system -c - if (iline .ne. 1) then -c -c Not first line. -c Get corrected poe = points/elemskip for *previous* system -c - wdpt = widthpt*(1-fracindent) - poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/ - * (elsktot+fbar*nbarss-scaldold) - isyscnt = isyscnt+1 - poevec(isyscnt) = poe -c -c Transfer data for system into global arrays to hold until very end -c - do 9 ia = 1 , nasksys - iask = iask+1 - ask(iask) = wasksys(ia)/poe-abs(elasksys(ia)) -c -c Only admit negative ask if it was user-defined space, signalled by elask<=0. -c - if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.) -9 continue - do 25 ia = 1 , nhssys - nhstot = nhstot+1 - hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.) -25 continue -c -c Reset counters for new system -c - scaldold = 0. - fixednew = 0. - nasksys = 0 - nhssys = 0 - end if -c -c End of if block for first bar of non-first system. Still 1st bar, any system -c - if (islast.and.figbass) write(11,'(a)')sq//'fixdrop%' - isystpg = isystpg+1 -c -c Try moving the next stmt way down, to fix a bug and get \eject printed at -c end of single-system page. -c if (isystpg .eq. nsystp(ipage)) isystpg = 0 - read(12,*)nbarss,elsktot,fsyst,frac,eonk,ewmxk - if (iline .gt. 1) fracindent=frac - if (figbass) then - ifigdr(1,iline) = 4 - ifigdr(2,iline) = 4 - end if - slfac = slfac1*musicsize*elsktot - if (iline .ne. 1) then -c -c For the line just _finished_, put figdrop in separate file. -c - if (figbass) write(14,'(a9,i2,a10,i2,1x,a4)') - * sq//'figdrop=',ifigdr(1,iline-1), - * ' '//sq//'figdtwo=',ifigdr(2,iline-1),sq//'or%' -c -c Check slurs in top staff for interference w/ barno. Only check when -c # if digits in barno >= |isig| But to keep on/off phasing, must ALWAYS -c keep track of ons and offs when |isig|<=3. -c - ndigbn = int(alog10(ibarcnt+ibcoff+.01))+1 - isnx = 0 - if (ndigbn.ge.iabs(isig) .and. is1n1.gt.0) then -c -c There's a slur in top voice over the line break, hgt=is1n1, idcode=is2n1 -c Look for termination in remainder of this input block. If not found, -c just use is1n1. Remember, haven't slid down yet. -c - ioff = 0 - if (ibar .gt. 1) ioff = nib(ivmx(nv,nvmx(nv)),ibar-1) - do 50 isdat = 1 , nsdat - if (igetbits(isdat1(isdat),5,13).eq.ivmx(nv,nvmx(nv)) - * .and. .not.btest(isdat1(isdat),11) - * .and. igetbits(isdat1(isdat),7,19).eq.is2n1) then -c -c Found slur ending. Just check note height, can't do fine adjustments. -c -c is1n1 = max(is1n1,igetbits(isdat2(nsdat),7,19)) - is1n1 = max(is1n1,igetbits(isdat2(isdat),7,19)) - go to 51 - end if -50 continue -c -c If exiting loop normally, did not find end of slur. c'est la vie. -c -51 continue - isnx = idim(is1n1,ncmid(nv,1)+1+irzbnd) - if (isnx .gt. 0) then -c -c AHA! Slur likely to interfere with barno. -c -c Modified 090525 to use \bnrs -c - slint = .true. - fmtq = '(a16,i1,a14)' - if (irzbnd+isnx .gt. 9) fmtq = '(a16,i2,a14)' - if (islast) write(11,fmtq)sq//'def'//sq//'raisebarno{', - * irzbnd+isnx,'.5'//sq//'internote}%' -c if (islast) then -c if (isnx .le. 9) then -c write(11,'(a5,i1,a2)')sq//'bnrs',isnx,'0%' -c else -c write(11,'(a6,i2,a3)')sq//'bnrs{',isnx,'}0%' -c end if -c end if -c - end if - end if - if (movbrk .gt. 0) then -c -c movbrk = 0 -c Move the reset down, so can use movbrk>0 to stop extra meter prints. -c -c New movement. Redefine stoppiece, contpiece. These will be called either -c explicitly or as part of alaligne. -c indsym = 0,1,2 for doubleBAR , doublebar, rightrepeat. -c This is passed to \newmovement. -c - if (rptfq2 .eq. 'E') rptfq2 = 'D' - indsym = index('Ddrbz',rptfq2)-1 - rptfq2 = 'E' -c -c Also check for Rd or Rr set the normal way -c - if (btest(islnow,8)) then - indsym = 1 - else if (btest(islnow,6)) then - indsym = 2 - end if - if (indsym .lt. 0) then - print* - print*,'Illegal end symbol before "/"' - call stop1() - end if -c -c Check for continuation (no bar number reset) -c - if (islast.and. - * nobar1) write(11,'(a)')sq//'advance'//sq//'barno1' - * //sq//'startbarno'//sq//'barno%' - if (movgap .lt. 10) then - if (islast) write(11,'(a12,2i1,a1)') - * sq//'newmovement',movgap,indsym,'%' - else - if (islast) write(11,'(a13,i2,a1,i1,a1)') - * sq//'newmovement{',movgap,'}',indsym,'%' - end if -c -c Change generalmeter if necessary -c - if (islast) call wgmeter(mtrnmp,mtrdnp) -c -c (Moved all name-writing to getnote, right when 'M' is detected) -c - if (btest(iplnow,28)) then -c -c Key signature at movement break -c - iplnow = ibclr(iplnow,28) - if (isig .gt. 0) then - if (islast) write(11,'(a18,i1,a2)') - * sq//'generalsignature{',isig,'}%' - else - if (islast) write(11,'(a18,i2,a2)') - * sq//'generalsignature{',isig,'}%' - end if - if (islast .and. LaterInstTrans) then - call Writesetsign(nInstTrans,iInstTrans,iTransKey, - * LaterInstTrans) - end if - end if - if (parmov .ge. -.1) then -c -c Resent paragraph indentation -c - ipi = parmov*widthpt+.1 - if (ipi .lt. 10) then - if (islast) write(11,'(a11,i1,a2)') - * sq//'parindent ',ipi,'pt' - else if (ipi .lt. 100) then - if (islast) - * write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt' - else - if (islast) - * write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt' - end if - end if - end if - if (isystpg .eq. 1) then -c -c First line on a page (not 1st page, still first bar). Tidy up old page -c then eject. -c -c Removed this 5/13/01 as it was causing double endvoltas. This probably -c is only needed at the end in case there is no endvolta specified. -c if (onvolt) then -cc if (islast) write(11,'(a)')sq//'endvoltabox%' -cc onvolt = .false. -c end if -c -c -c Check for meter change at start of a new PAGE -c - if (mtrnuml .gt. 0) then -c -c Meter change at start of a new page. Ugly repeated coding here. -c - mtrnms = mtrnuml - call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) - mtrnuml = mtrnms - if (movbrk .eq. 0 .and. islast) - * call wgmeter(mtrnmp,mtrdnp) - end if -c -c Key signature change? -c - if (btest(iplnow,28) .and. movbrk.eq.0) then - notexq = sq//'xbar'//sq//'addspace{-'//sq// - * 'afterruleskip}'//sq//'generalsignature{' - lnote = 49 - if (isig .lt. 0) then - notexq = notexq(1:49)//'-' - lnote = 50 - end if - if (islast) write(11,'(a)') - * notexq(1:lnote)//chax(48+abs(isig))//'}%' - if (islast .and. LaterInstTrans) then - call Writesetsign(nInstTrans,iInstTrans,iTransKey, - * LaterInstTrans) - end if - if (islast) write(11,'(a)')sq//'zchangecontext'//sq - * //'addspace{-'//sq//'afterruleskip}' - * //sq//'zstoppiece'//sq//'PMXbarnotrue%' - else if (mtrnuml.gt.0 .and. movbrk.eq.0) then -c -c Meter change but no signature change -c - if (islast) - * write(11,'(a)')sq//'xchangecontext'//sq//'addspace{-'// - * sq//'afterruleskip}'//sq//'let'//sq//'bnat'//sq// - * 'barnoadd%' - if (islast) - * write(11,'(a)')sq//'def'//sq//'barnoadd{'//sq//'let'// - * sq//'barnoadd'//sq//'bnat}'//sq//'zstoppiece%' - else - if (islast) write(11,'(a)')sq//'stoppiece%' - end if -c -c This is the key spot when vshrink is used. Value of vshrink here comes from -c just after the prior pagebreak, i.e., it is not affected by "Av" -c that may have been entered at this pagebreak, since that only affects usevshrink. -c So choose page *ending* (with or without \vfill) depending on old vshrink. Then -c check value of usevshrink to reset vshrink if necessary for the new page, where -c we have to set \interstaff and later call puttitle. -c Top of first page needs special treatment. For this we use -c novshrinktop, which was set in g1etnote on the first pass, since on -c second pass, vshrink at top of page one is dealt with in topfile, which is called -c *before* any reading in any "Av" at the top of the first input block. -c - if (.not.vshrink) then - xnstbot = xnsttop(ipage)*etabot/etatop - if (xnstbot .lt. 9.95) then - fmtq = '(a,f3.1,a)' - else - fmtq = '(a,f4.1,a)' - end if - if (islast) write(11,fmtq)sq//'vskip',xnstbot, - * sq//'Interligne'//sq//'eject%' - else - if (islast) write(11,'(a)') sq//'vfill'//sq//'eject%' - end if - ipage = ipage+1 -c -c Now that page is ejected, compute new vshrink -c - vshrink = xintstaff(ipage).gt.20 .and. usevshrink - if (vshrink) then - xinsnow = 10 - else - xinsnow = xintstaff(ipage) - end if - if (fintstf.gt.0 .and. ipage.gt.1) then - xinsnow = xinsnow*fintstf/gintstf - fintstf = -1. - end if - if (xinsnow .lt. 9.95) then - fmtq = '(a,f3.1,a)' - else if (xinsnow .lt. 99.95) then - fmtq = '(a,f4.1,a)' - else - fmtq = '(a,f5.1,a)' - end if -c -c Vertical spacing parameters, then restart -c - if (islast) write(11,fmtq)sq//'interstaff{',xinsnow, - * '}'//sq//'contpiece' -c -c Check for meter change at start of a new PAGE -c - if (mtrnuml .gt. 0) then -c -c Meter change at start of a new page -c - call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) - if (movbrk .eq. 0) then - if (islast) call wgmeter(mtrnmp,mtrdnp) - if (mtrdnp .gt. 0) then - if (islast) write(11,'(a)')sq//'newtimes2%' - if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize - end if - end if - end if -c -c If no real titles here, which there probably will never be, make vertical -c space at page top with \titles{...}. headlog=.false.<=>no real titles -c - call puttitle(inhnoh,xnsttop(ipage),etatop, - * sq,etait,etatc,etacs1,nv,vshrink,sepsymq) - if (HeaderSpecial) -c -c Write special header for first page -c - * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%' - else -c -c First bar of system, not a new page, force line break -c - if (btest(iplnow,28)) then -c -c Signature change -c - notexq = sq//'xbar'//sq//'addspace{-'//sq// - * 'afterruleskip}'//sq//'generalsignature{' - lnote = 49 - if (isig .lt. 0) then - notexq = notexq(1:49)//'-' - lnote = 50 - end if - if (islast) write(11,'(a)')notexq(1:lnote) - * //chax(48+abs(isig))//'}%' - if (islast .and. LaterInstTrans) then - call Writesetsign(nInstTrans,iInstTrans,iTransKey, - * LaterInstTrans) - end if - if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%' - if (mtrnuml .ne. 0) then -c -c Meter+sig change, new line, may need mods if movement break here. -c - call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) - if (islast) then - call wgmeter(mtrnmp,mtrdnp) - write(11,'(a)')sq//'xchangecontext'//sq// -c * 'addspace{-'//sq//'afterruleskip}'//sq//'def' - * 'addspace{-'//sq//'afterruleskip}' -c * //sq//'writezbarno{}'//sq//'zalaligne%' - * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%' - write(11,'(a)')sq//'addspace{-'//sq - * //'afterruleskip}%' - call wgmeter(mtrnmp,mtrdnp) - write(11,'(a)')sq//'zchangecontext' - end if - else - if (islast) write(11,'(a)')sq//'xchangecontext'//sq// -c * 'addspace{-'//sq//'afterruleskip}'//sq//'def'// - * 'addspace{-'//sq//'afterruleskip}' -c * sq//'writezbarno{}'//sq//'zalaligne%' - * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%' - end if - else if (mtrnuml .eq. 0) then -c -c No meter change -c - if (islast) write(11,'(a)')sq//'alaligne' - else -c -c New meter, no new sig, end of line, not new page. -c -c \generalmeter{\meterfrac{3}{4}}% -c \xchangecontext\addspace{-\afterruleskip}% -c \zalaligne\generalmeter{\meterfrac{3}{4}}\addspace{-\afterruleskip}% -c \zchangecontext -c - call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) - if (movbrk .eq. 0) then - if (islast) call wgmeter(mtrnmp,mtrdnp) - if (mtrdnp .gt. 0) then - if (islast) then - write(11,'(a)') - * sq//'let'//sq//'bnat'//sq//'barnoadd' - * //sq//'def'//sq//'barnoadd{'//sq//'empty}%' - write(11,'(a)')sq//'xchangecontext'//sq// - * 'addspace{-'//sq//'afterruleskip}'//sq// - * 'zalaligne'//sq//'let'//sq//'barnoadd'//sq//'bnat' - call wgmeter(mtrnmp,mtrdnp) - write(11,'(a)')sq//'addspace{-'//sq// - * 'afterruleskip}'//sq//'zchangecontext' - end if - if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize - else - if (islast) write(11,'(a)')sq//'alaligne' - end if - else - if (islast) write(11,'(a)')sq//'alaligne' - end if - end if - end if -c -c Modified 090525 to use \bnrs -c - if (slint) then - slint = .false. - if (islast) write(11,'(a16,i1,a14)')sq//'def'//sq// - * 'raisebarno{',irzbnd,'.5'//sq//'internote}%' - end if - movbrk = 0 - end if -c -c Clean up if we squelched bar number reset at movement break -c - if (nobar1) then - if (islast) write(11,'(a)')sq//'startbarno1' - nobar1 = .false. - end if - read(12,*,end=14)iauto -14 continue -c -c We come thru here for the 1st bar of every system, so initialize is1n1 -c - is1n1 = 0 -c -c Brought down from above -c - if (isystpg .eq. nsystp(ipage)) isystpg = 0 -c -c Check for linebreak ties -c - if (ispstie) - * call LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat, - * ispstie,sepsymq) - else -c -c Not first bar of system -c - if (btest(iplnow,28)) then -c -c Signature change -c - if (mtrnuml .ne. 0) then -c -c Meter+signature change mid line, assume no movement break -c - call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) - if (islast) call wgmeter(mtrnmp,mtrdnp) - notexq = sq//'generalsignature{' - lnote = 18 - if (isig .lt. 0) then - notexq = notexq(1:18)//'-' - lnote = 19 - end if - if (islast) then - iptemp = 48+abs(isig) - charq = chax(iptemp) - notexq = notexq(1:lnote)//charq//'}%' - lnote = lnote+3 - write(11,'(a)')notexq(1:lnote) - if (islast .and. LaterInstTrans) then - call Writesetsign(nInstTrans,iInstTrans,iTransKey, - * LaterInstTrans) - end if - write(11,'(a)')sq//'xchangecontext%' - end if - if (ibar .eq. ibarmbr) then -c -c Compute space for multibar rest -c - if (lastisig*isig .ge. 0) then - naccs = max(abs(lastisig),abs(isig)) - else - naccs = abs(lastisig-isig) - end if - xb4mbr = (facmtr+naccs*.24)*musicsize - end if - else -c -c Signature change only -c - notexq = sq//'xbar'//sq//'addspace{-'//sq// - * 'afterruleskip}'//sq//'generalsignature{' - lnote = 49 - if (isig .lt. 0) then - notexq = notexq(1:49)//'-' - lnote = 50 - end if - if (islast) - * write(11,'(a)')notexq(1:lnote)//chax(48+abs(isig))//'}%' - if (islast .and. LaterInstTrans) then - call Writesetsign(nInstTrans,iInstTrans,iTransKey, - * LaterInstTrans) - end if - if (islast) write(11,'(a)')sq//'zchangecontext'//sq - * //'addspace{-.5'// sq//'afterruleskip}%' - if (ibar .eq. ibarmbr) then -c -c Compute space for multibar rest -c - if (lastisig*isig .ge. 0) then - naccs = max(abs(lastisig),abs(isig)) - else - naccs = abs(lastisig-isig) - end if - xb4mbr = naccs*.24*musicsize - end if - end if - else if (mtrnuml .eq. 0) then -c -c No meter change -c - if (islast) write(11,'(a)')sq//'xbar' - else -c -c Change meter midline -c - call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) - if (movbrk .eq. 0) then - if (islast) call wgmeter(mtrnmp,mtrdnp) - if (mtrdnp .gt. 0) then - if (islast) write(11,'(a,2i1,a)')sq//'newtimes0%' - if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize - else - if (islast) write(11,'(a)')sq//'xbar' - end if - end if - end if - end if -c -c Now that xbar's are written, can put in left-repeats at line beginnings -c - if (lrptpend) then - if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1' - * //sq//'leftrepeat' - lrptpend = .false. - end if - if (ibar .gt. 1) then -c -c For bars after first, slide all stuff down to beginning of arrays -c - do 11 iv = 1 , nv - do 11 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - ioff = nib(ivx,ibar-1) - do 12 ip = 1 , nib(ivx,ibar)-ioff - nolev(ivx,ip) = nolev(ivx,ip+ioff) - nodur(ivx,ip) = nodur(ivx,ip+ioff) - nacc(ivx,ip) = nacc(ivx,ip+ioff) - irest(ivx,ip) = irest(ivx,ip+ioff) - islur(ivx,ip) = islur(ivx,ip+ioff) - ipl(ivx,ip) = ipl(ivx,ip+ioff) - iornq(ivx,ip) = iornq(ivx,ip+ioff) - mult(ivx,ip) = mult(ivx,ip+ioff) -c if (ivx.le.2 .and. figbass) -c * isfig(ivx,ip) = isfig(ivx,ip+ioff) - if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then - if (ivx.eq.1) then - isfig(1,ip) = isfig(1,ip+ioff) - else - isfig(2,ip) = isfig(2,ip+ioff) - end if - end if -12 continue - if (ivx.le.nv .and. ncc(iv).gt.1) then - islide = 0 - do 13 icc = 1 , ncc(iv) - if (tcc(iv,icc) .le. lenbar) then -c -c This time will drop <=0 when slid. -c - islide = icc-1 - ncmidcc(iv,1) = ncmidcc(iv,icc) - else - tcc(iv,icc-islide) = tcc(iv,icc)-lenbar - ncmidcc(iv,icc-islide) = ncmidcc(iv,icc) - end if -13 continue - ncc(iv) = ncc(iv)-islide - tcc(iv,1) = 0. - end if -11 continue - do 15 ig = 1 , ngrace - ipg(ig) = ipg(ig)-nib(ivg(ig),ibar-1) - if (ibar .gt. 2) ipg(ig) = ipg(ig)+nib(ivg(ig),ibar-2) -15 continue - do 21 il = 1 , nlit - iplit(il) = iplit(il)-nib(ivlit(il),ibar-1) - if (ibar .gt. 2) iplit(il) = iplit(il)+nib(ivlit(il),ibar-2) -21 continue - do 22 it = 1 , ntrill - iptrill(it) = iptrill(it)-nib(ivtrill(it),ibar-1) - if (ibar .gt. 2) iptrill(it) = - * iptrill(it)+nib(ivtrill(it),ibar-2) -22 continue - do 27 icrd = 1 , ncrd -c ivx = iand(15,ishft(icrdat(icrd),-8)) - ivx = iand(15,ishft(icrdat(icrd),-8)) - * +16*igetbits(icrdat(icrd),1,28) - ipnew = iand(255,icrdat(icrd))-nib(ivx,ibar-1) - if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2) - icrdat(icrd) = iand(not(255),icrdat(icrd)) - icrdat(icrd) = ior(max(0,ipnew),icrdat(icrd)) -27 continue - do 29 iudorn = 1 , nudorn -c ivx = iand(15,ishft(kudorn(iudorn),-8)) - ivx = ivxudorn(iudorn) - ipnew = iand(255,kudorn(iudorn))-nib(ivx,ibar-1) - if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2) - kudorn(iudorn) = iand(not(255),kudorn(iudorn)) - kudorn(iudorn) = ior(max(0,ipnew),kudorn(iudorn)) -29 continue - do 42 idyn = 1 , ndyn - idynd = idyndat(idyn) -c ivx = iand(15,idynd) - ivx = iand(15,idynd)+16*igetbits(idynda2(idyn),1,10) - ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1) -c -c The following construction avoids array bound errors in some compilers -c - if (ibar .gt. 2) then - ipnew = ipnew+nib(ivx,ibar-2) - end if - ipnew = dim(ipnew,0) - call setbits(idynd,8,4,ipnew) - idyndat(idyn) = idynd -42 continue - do 43 itxtdyn = 1 , ntxtdyn - idynd = ivxiptxt(itxtdyn) -c ivx = iand(15,idynd) - ivx = iand(31,idynd) -c ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1) - ipnew = igetbits(idynd,8,5)-nib(ivx,ibar-1) - if (ibar .gt. 2) then - ipnew = ipnew+nib(ivx,ibar-2) - end if - ipnew = dim(ipnew,0) -c call setbits(idynd,8,4,ipnew) - call setbits(idynd,8,5,ipnew) - ivxiptxt(itxtdyn) = idynd -43 continue - do 41 isdat = 1 , nsdat - isdata = isdat1(isdat) - ivx = ivmx(igetbits(isdata,5,13),igetbits(isdata,1,12)+1) - ipnew = igetbits(isdata,8,3)-nib(ivx,ibar-1) - if (ibar .gt. 2) then - ipnew = ipnew+nib(ivx,ibar-2) - end if - ipnew = dim(ipnew,0) - call setbits(isdata,8,3,ipnew) - isdat1(isdat) = isdata -41 continue - do 44 ibc = 1 , nbc -c ivx = iand(15,ibcdata(ibc)) - ivx = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) - ipnew = igetbits(ibcdata(ibc),8,4)-nib(ivx,ibar-1) - if (ibar .gt. 2) then - ipnew = ipnew+nib(ivx,ibar-2) - end if - ipnew = dim(ipnew,0) - call setbits(ibcdata(ibc),8,4,ipnew) -44 continue - do 45 iarps = 1 , NumArpShift - IpArpShift(iarps) = - * IpArpShift(iarps)-nib(IvArpShift(iarps),ibar-1) - if (ibar .gt. 2) then - IpArpShift(iarps) = - * IpArpShift(iarps)+nib(IvArpShift(iarps),ibar-2) - end if -45 continue -c -c Bookkeeping for figures. This will set nfigs = 0 if there are no figs left. -c If there are figs left, it will reset all times relative to start of -c current bar. -c - do 46 ivx = 1 , 2 - if (figbass) then - islide = 0 - do 20 jfig = 1 , nfigs(ivx) - if (itfig(ivx,jfig) .lt. lenbar) then -c -c This figure was already used -c - islide = jfig - else - itfig(ivx,jfig-islide) = itfig(ivx,jfig)-lenbar - figq(ivx,jfig-islide) = figq(ivx,jfig) - itoff(ivx,jfig-islide) = itoff(ivx,jfig) - ivupfig(ivx,jfig-islide) = ivupfig(ivx,jfig) - end if -20 continue - nfigs(ivx) = nfigs(ivx)-islide - end if - if (nfigs(2) .eq. 0) go to 47 -46 continue -47 continue - end if -c -c End of sliding down for bars after first in gulp. -c -c The following may not be needed by makeabar, but just in case... -c - if (firstgulp .and. lenb0.ne.0) then - if (ibar .eq. 1) then - lenbar = lenb0 - else - lenbar = lenb1 - end if - end if -c -c Equal line spacing stuff -c - if (equalize .and. bar1syst) then - if (isystpg .eq. 1) then - write(11,'(a)')sq//'starteq%' - else if (isystpg .eq. nsystp(ipage)-1) then - write(11,'(a)')sq//'endeq%' - end if - end if - call make1bar(ibmrep,tglp1,tstart,cwrest,squez, - * istop,numbms,istart) - call make2bar(ninow,tglp1,tstart,cwrest,squez, - * istop,numbms,istart,clefq) -c -c Hardspace before barline? -c - hardb4 = 0. - do 35 iv = 1 , nv - do 35 kv = 1 , nvmx(iv) - ivx = ivmx(iv,kv) - if (btest(irest(ivx,nn(ivx)),18)) then - nudoff(ivx) = nudoff(ivx)+1 - hardb4 = max(hardb4,udoff(ivx,nudoff(ivx))) - end if -35 continue - if (hardb4 .gt. 0.) then - if (islast) write(11,'(a11,f5.1,a4)')sq - * //'hardspace{',hardb4,'pt}%' - fixednew = fixednew-hardb4 - end if -10 continue - firstgulp = .false. - lenb0 = 0 - go to 30 -40 close(12) - close(13) - ilbuf = 1 - ipbuf = 0 - wdpt = widthpt - if (iline .eq. 1) wdpt = widthpt*(1-fracindent) - poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/ - * (elsktot+fbar*nbarss-scaldold) - poevec(nsyst) = poe - if (.not.islast) then - close(11) - close(16) - if (figbass) close(14) - return - end if - do 19 ia = 1 , nasksys - iask = iask+1 - ask(iask) = wasksys(ia)/poe-abs(elasksys(ia)) - if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.) -19 continue - do 26 ia = 1 , nhssys - nhstot = nhstot+1 - hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.) -26 continue - if (islast .and. - * onvolt) write(11,'(a)')sq//'endvoltabox' - if (rptfq2 .ne. 'E') then -c -c Terminal repeat. Right or double? -c - if (rptfq2 .eq. 'r') then - if (islast) write(11,'(a)')sq//'setrightrepeat' - * //sq//'endpiece' - else if (rptfq2 .eq. 'd') then - if (islast) write(11,'(a)')sq//'setdoublebar'//sq//'endpiece' - else if (rptfq2 .eq. 'b') then - if (islast) write(11,'(a)')sq//'endpiece' - else if (rptfq2 .eq. 'z') then - if (islast) write(11,'(a)')sq//'setzalaligne'//sq//'Endpiece' - else -c else if (rptfq2 .ne. 'D') then - print* - print*,'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2 - write(15,*)'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2 - if (islast) write(11,'(a)')sq//'Endpiece' - end if - else - if (islast) write(11,'(a)')sq//'Endpiece' - end if - if (.not.vshrink) then - xnstbot = xnsttop(ipage)*etabot/etatop - if (xnstbot .lt. 9.95) then - fmtq = '(a,f3.1,a)' - else - fmtq = '(a,f4.1,a)' - end if - if (islast) write(11,fmtq)sq//'vskip',xnstbot, - * sq//'Interligne'//sq//'eject'//sq//'endmuflex' - if (islast) write(11,'(a)')sq//'bye' - else - if (islast) write(11,'(a)') - * sq//'vfill'//sq//'eject'//sq//'endmuflex' - if (islast) write(11,'(a)')sq//'bye' - end if - rewind(11) - if (figbass) then - write(14,'(a9,i2,a10,i2,1x,a5)') - * sq//'figdrop=',ifigdr(1,iline), - * ' '//sq//'figdtwo=',ifigdr(2,iline),sq//'fi}%' - rewind(14) - end if - call askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0) - if (.not.optimize) then - print* - print*,'Writing ' - * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex' - print*,'Done with second PMX pass.' - write(15,'(/,a)')'Writing ' - * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex' - write(15,'(a)')' Done with second PMX pass. Now run TeX' - end if - return - end - subroutine poestats(nsyst,poe,poebar,devnorm) - parameter (nks=125) -c -c Compute avg. & norm. std. dev. of poe. -c - real*4 poe(nks) - sumx = 0. - sumxx = 0. - do 1 isyst = 1 , nsyst - sumx = sumx+poe(isyst) - sumxx = sumxx+poe(isyst)**2 -1 continue -2 continue - devnorm = sqrt(nsyst*sumxx/sumx**2-1) - poebar = sumx/nsyst - return - end - subroutine precrd(ivx,ip,nolevm,nacc,ipl,irest,udq, - * twooftwo,icashft) -c -c Analyzes chords, data to be used with slurs on chords and plain chords. -c Check for 2nds, shift notes if neccesary. -c ipl(10) chord present -c irest(20) set if any note is right shifted -c irest(27) set if any note is left shifted -c ipl(8|9) left|right shift main note -c icrdat(23|24) ditto chord note -c udq is updown-ness, needed to analyze 2nds. -c levtabl(i)=0 if no note at this level, -1 if main note, icrd if chord note. -c icrdot(icrd)(27-29) sequence order of chord note if accid, top down -c - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - logical btest,is2nd,twooftwo - integer*4 kicrd(10),levtabl(88) - character*1 udq - do 11 i = 1 , 88 - levtabl(i) = 0 -11 continue - do 1 icrd1 = 1 , ncrd - ivx1 = iand(15,ishft(icrdat(icrd1),-8)) - * +16*igetbits(icrdat(icrd1),1,28) - ip1 = iand(255,icrdat(icrd1)) - if (ip1.eq.ip .and. ivx1.eq.ivx) go to 2 -1 continue - print* - print*, - * 'Cannot find first chord note in precrd. Send source to Dr. Don!' - call stop1() -2 continue - maxlev = nolevm - minlev = nolevm - levtabl(nolevm) = -1 - is2nd = .false. - naccid = 0 - levmaxacc = -100 - levminacc = 1000 -c -c Check 1st 3 bits of nacc for accid on main note of chord. -c - if (iand(7,nacc) .gt. 0) then - naccid = 1 -c -c Start list of notes with accid's. There will be naccid of them. kicrd=0 if main, -c otherwise icrd value for note with accidental. -c - kicrd(1) = 0 - levmaxacc = nolevm - levminacc = nolevm -c -c Start the level-ranking -c - icrdot0 = 1 - end if - do 3 icrd2 = icrd1 , ncrd - nolev = igetbits(icrdat(icrd2),7,12) - levtabl(nolev) = icrd2 - maxlev = max(maxlev,nolev) - minlev = min(minlev,nolev) -c -c Check for accidental -c - if (btest(icrdat(icrd2),19)) then - naccid = naccid+1 - levmaxacc = max(levmaxacc,nolev) - levminacc = min(levminacc,nolev) -c -c Add this icrd to list of values for notes with accid's. -c - kicrd(naccid) = icrd2 - if (.not.btest(nacc,28)) then -c -c Order not forced, so get the level-ranking, top down -c - iorder = 1 - do 12 iaccid = 1 , naccid-1 - if (kicrd(iaccid) .eq. 0) then - if (nolevm .gt. nolev) then - iorder = iorder+1 - else - icrdot0 = icrdot0+1 - end if - else - if (igetbits(icrdat(kicrd(iaccid)),7,12) - * .gt. nolev) then - iorder = iorder+1 - else - iold = igetbits(icrdot(kicrd(iaccid)),3,27) - call setbits(icrdot(kicrd(iaccid)),3,27,iold+1) - end if - end if -12 continue - call setbits(icrdot(icrd2),3,27,iorder) - end if - end if -c -c Exit loop if last note in this chord -c - if (icrd2 .eq. ncrd) go to 4 - if (igetbits(icrdat(icrd2+1),8,0) .ne. ip .or. -c * igetbits(icrdat(icrd2+1),4,8) .ne. ivx) go to 4 - * igetbits(icrdat(icrd2+1),4,8) - * +16*igetbits(icrdat(icrd2+1),1,28) .ne. ivx) go to 4 -3 continue - print* - print*,'Failed to find last chord note. Send source to Dr. Don!' - call stop1() -4 continue -c -c Now icrd1, icrd2 define range of icrd for this chord. -c -c Bypass autos-shifting if any manual shifts are present -c - if (btest(irest,20) .or. btest(irest,27)) go to 10 -c -c Check for 2nds -c - do 5 ilev = 1 , 87 - if (levtabl(ilev).ne.0 .and. levtabl(ilev+1).ne.0) then -c -c There is at least one 2nd.. -c - if (udq .eq. 'u') then -c -c Upstem. Start with 2nd just found and go up, rt-shifting upper -c member of each pair -c - ile = ilev -c -c Set main-note flag for ANY right-shift -c - irest = ibset(irest,20) -7 continue - if (levtabl(ile+1) .lt. 0) then -c -c Upstem, & upper member is main so must be rt-shifted. This would move -c stem too, so we rt-shift the OTHER note, and set flag that signals -c to interchange pitches just when these two notes are placed. -c - nacc = ibset(nacc,30) - icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),24) - else -c -c Upper member is chord note, must be rt-shifted -c - icrdat(levtabl(ile+1)) = ibset(icrdat(levtabl(ile+1)),24) - end if - ile = ile+1 -8 continue - ile = ile+1 - if (ile .lt. 87) then - if (levtabl(ile).ne.0 .and. levtabl(ile+1).ne.0) then - go to 7 - else - go to 8 - end if - end if - go to 10 - else -c -c Downstem. Start at top and work down, left-shifting lower member of each pair. -c We know that lowest pair is at (ilev,ilev+1). -c - ile = 88 -c -c Set main-note flag for ANY right-shift -c - irest = ibset(irest,27) -9 continue - if (levtabl(ile).ne.0 .and. levtabl(ile-1).ne.0) then - if (levtabl(ile-1) .lt. 0) then -c ipl = ibset(ipl,8) -c -c Dnstem, & lower member is main so must be left-shifted. This would move -c stem too, so we left-shift the OTHER note, and set flag that signals -c to interchange pitches just when these two notes are placed. -c - nacc = ibset(nacc,31) - icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),23) - else -c -c Lower member is chord note, must be shifted -c - icrdat(levtabl(ile-1)) = - * ibset(icrdat(levtabl(ile-1)),23) - end if - ile = ile-1 - end if - ile = ile-1 - if (ile .ge. ilev+1) go to 9 - go to 10 - end if - end if -5 continue -10 continue -c -c Done with 2nds, now do accid's. Call even if just one, in case left shifts. -c -c if (naccid .gt. 1) call crdaccs(nacc,ipl,irest,naccid, - if (naccid .ge. 1) call crdaccs(nacc,ipl,irest,naccid, - * kicrd,nolevm,levmaxacc,levminacc,icrdot0,twooftwo,icashft) - return - end - subroutine printl(string) - character*(*) string -c -c Send string to console and to log file -c - print*,string - write(15,'(a)')string - return - end - subroutine putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) - common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), - * xinsnow,lowdot - common /comtol/ tol - common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), - * ArpShift(20) - logical lowdot,IsArpShift - character*80 soutq - character*79 notexq - character*8 symq(2) - character*1 chax - data symq /'raisearp','arpeggio'/ - -c -c Find which iarp, if any -c - do 1 iarp = 1 , narp - if (abs(tnow-tar(iarp)).lt.tol) go to 2 -1 continue -c -c If here, this is the *first* call for this arp. -c - narp = narp+1 - tar(narp) = tnow+tol*.5 - ivar1(narp) = iv - ipar1(narp) = ip - levar1(narp) = nolev - ncmar1(narp) = ncm - return -2 continue -c -c If here, this is *second* call at this time, iarp points to values from 1st. -c -c Check for shift. Set IsArpShift and iarps -c - do 3 iarps = 1 , NumArpShift - if (IvArpShift(iarps) .eq. ivar1(iarp) .and. - * IpArpShift(iarps) .eq. ipar1(iarp)) then - IsArpShift = .true. - notexq = chax(92)//'loffset{' - write(notexq(10:14),'(f3.1,a2)') Arpshift(iarps),'}{' - lnote = 14 - go to 4 - end if -3 continue - IsArpShift = .false. - lnote = 0 -4 continue - if (iv .eq. ivar1(iarp)) then -c -c Arp is in a single staff. -c - levbot = min(levar1(iarp),nolev)-ncm+3 - invert = abs(levar1(iarp)-nolev)+1 - else -c -c Arp covers >1 staff. Lower staff has to be the first, upper is current and -c is where the symbol will be written. -c - levbot = -nint(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp) - invert = -levbot+4+nolev-ncm -c print*,'xinsnow,levar1,ncmar1,levbot,nolev,ncm:' -c write(*,'(f5.1,5i5)')xinsnow,levar1(iarp),ncmar1(iarp), -c *levbot,nolev,ncm - end if -c -c isym will be (1,2) if invert is (even,odd). If even, raise .5\internote -c - isym = mod(invert,2)+1 - ilvert = (invert+1)/2 - if (levbot .ge. 0 .and. levbot .le. 9) then -c -c Single digit -c - if (.not.IsArpShift) then - notexq = chax(92)//symq(isym)//chax(48+levbot) - else - notexq = notexq(1:lnote)// - * chax(92)//symq(isym)//chax(48+levbot) - end if - lnote = lnote+10 - else - if (.not.IsArpShift) then - notexq = chax(92)//symq(isym)//'{' - else - notexq = notexq(1:lnote)//chax(92)//symq(isym)//'{' - end if - lnote = lnote+10 - if (levbot .ge. -9) then -c -c Need two spaces for number -c - write(notexq(lnote+1:lnote+3),'(i2,a1)')levbot,'}' - lnote = lnote+3 - else - write(notexq(lnote+1:lnote+4),'(i3,a1)')levbot,'}' - lnote = lnote+4 - end if - end if -c if (ilvert .le. 9) then -c call addstr(notexq(1:lnote)//chax(48+ilvert),lnote+1, -c * soutq,lsout) -c else -c write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}' -c call addstr(notexq(1:lnote+4),lnote+4,soutq,lsout) -c end if - - if (ilvert .gt. 9) then - write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}' - lnote = lnote+4 - else - notexq = notexq(1:lnote)//chax(48+ilvert) - lnote = lnote+1 - end if - if (IsArpShift) then - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - end if - call addstr(notexq(1:lnote),lnote,soutq,lsout) -c -c cancel out the stored time, to permit two arps at same time! -c - tar(iarp) = -1. - return - end - subroutine putast(elask,indxask,outq) - character*129 outq,tag - character*9 fmtq - if (elask .ge. 0.) then - if (elask.lt.0.995) then - lp = 3 - else if (elask .lt. 9.995) then - lp = 4 - else - lp = 5 - end if - write(fmtq,'(a5,i1,a3)')'(a2,f',lp,'.2)' - else - lp = 5 - fmtq = '(a2,f5.1)' - end if -c -c Overwrite as follows: ...xyz*ask *lmnop... -> -c ...xyz*ast{.nn}*lmnop... -c ...xyz*ast{n.nn}*lmnop... -c ...xyz*ast{nn.nn}*lmnop... -c or for negative, ...xyz*ast{-nn.n}*lmnop... - tag = outq(indxask+9:) - write(outq(indxask+3:),fmtq)'t{',elask - outq = outq(1:indxask+4+lp)//'}'//tag - return - end - subroutine putcb(ivx,ip,notexq,lnote) - common /comcb/ nbc,ibcdata(36) - character*79 notexq - logical btest -c ivxip = ivx+16*ip - do 1 ibc = 1 , nbc -c if (ivxip .eq. iand(1023,ibcdata(ibc))) go to 2 -c if (ivx.eq.iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) -c * .and. ip.eq.iand(1008,ibcdata(ibc))) go to 2 - ivxbc = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) - ipbc = igetbits(ibcdata(ibc),8,4) - if (ivx .eq. ivxbc .and. ip .eq.ipbc) go to 2 -1 continue - call printl('Error in putbc, Call Dr. Don') - stop -2 continue - if (btest(ibcdata(ibc),27)) then - lnote = 8 - notexq = char(92)//'pbreath' - else - lnote = 9 - notexq = char(92)//'pcaesura' - end if - ivshft = igetbits(ibcdata(ibc),6,13) -c?? ivshft = igetbits(ibcdata(ibc),6,13)-32 - if (ivshft .gt. 0) ivshft = ivshft-32 - if (ivshft.lt.0 .or. ivshft.gt.9) then - notexq = notexq(1:lnote)//'{' - lnote = lnote+1 - if (ivshft .lt. -9) then - write(notexq(lnote+1:lnote+3),'(i3)')ivshft - lnote = lnote+3 - else - write(notexq(lnote+1:lnote+2),'(i2)')ivshft - lnote = lnote+2 - end if - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - else - notexq = notexq(1:lnote)//char(48+ivshft) - lnote = lnote+1 - end if - ihshft = igetbits(ibcdata(ibc),8,19) - if (ihshft .eq. 0) then - notexq = notexq(1:lnote)//'0' - lnote = lnote+1 - else - hshft = .1*(ihshft-128) -c -c -12.8<hshft<12.8 -c - notexq = notexq(1:lnote)//'{' - lnote = lnote+1 - if (hshft .lt. -9.95) then - write(notexq(lnote+1:lnote+5),'(f5.1)')hshft - lnote = lnote+5 - else if (hshft.lt.-0.05 .or. hshft.gt.9.95) then - write(notexq(lnote+1:lnote+4),'(f4.1)')hshft - lnote = lnote+4 - else - write(notexq(lnote+1:lnote+3),'(f3.1)')hshft - lnote = lnote+3 - end if - notexq = notexq(1:lnote)//'}' - lnote = lnote+1 - end if - return - end - subroutine putfig(ivx,ifig,offnsk,figcheck,soutq,lsout) - parameter (nm=24) - common /comfig/ itfig(2,74),figqq(2,74),ivupfig(2,74),nfigs(2), - * fullsize(nm),ivxfig2 - character*10 figqq,figq - character*80 soutq,notexq - character*1 ch1q,ch2q,sq,chax - character*5 nofq,nofaq - character*4 Figutq,Conttq - logical figcheck - if (ivx .eq. 1) then - Figutq = 'Figu' - Conttq = 'Cont' - else - Figutq = 'Figt' - Conttq = 'Cott' - end if - sq = chax(92) - if (abs(offnsk) .gt. .0001) then -c -c Write offset for floating figure, to two decimal places -c - notexq = sq//'off{' - if (-offnsk .lt. -9.995) then - write(notexq(6:11),'(f6.2)')-offnsk - lnote = 11 - else if (-offnsk.lt.-.995 .or. -offnsk.gt.9.995) then - write(notexq(6:10),'(f5.2)')-offnsk - lnote = 10 - else if (-offnsk.lt.-.0001 .or. -offnsk.gt..995) then - write(notexq(6:9),'(f4.2)')-offnsk - lnote = 9 - else - write(notexq(6:8),'(f3.2)')-offnsk - lnote = 8 - end if - notexq = notexq(1:lnote)//sq//'noteskip}' - call addstr(notexq,lnote+10,soutq,lsout) - end if - figq = figqq(ivx,ifig) - ic = 1 -c nof = 0 -c nofa = -1 - nof = -ivupfig(ivx,ifig) - nofa = -ivupfig(ivx,ifig)-1 -c -c Beginning of manual loop -c -1 ch1q = figq(ic:ic) -c -c Exit when first blank is encountered -c - if (ch1q .eq. ' ') go to 2 -c -c Starting a level. Set up vertical offset. -c -c lnof = 1 -c nofq = chax(nof+48) -c if (nof .gt. 9) then -c lnof = 2 -c nofq = '1'//chax(nof-10+48) -c end if -c if (nofa .eq.-1) then -c lnofa = 2 -c nofaq = '-1' -c else if (nofa .lt. 10) then -c lnofa = 1 -c nofaq = chax(nofa+48) -c else -c lnofa = 2 -c nofaq = '1'//chax(nofa+38) -c end if - call istring(nof,nofq,lnof) - call istring(nofa,nofaq,lnofa) - if (ch1q .eq. '0') then -c -c Continuation figure. Next number is length (in noteskips). The number will -c end at the first blank or char that is not digit or decimal point. If -c colon, it is a separator and must be skipped -c - icnum = ic+1 -3 continue - ic = ic+1 - if (index('0123456789.',figq(ic:ic)) .gt. 0) go to 3 - lnum = ic-icnum - call addstr(sq//Conttq//nofq(1:lnof)//'{' - * //figq(icnum:ic-1)//'}',7+ic-icnum+lnof,soutq,lsout) - if (figq(ic:ic) .ne. ':') ic=ic-1 - else if (ch1q.eq.'#'.or.ch1q.eq.'-'.or.ch1q.eq.'n') then - ic = ic+1 - ch2q = figq(ic:ic) - if (ch2q .eq. ' ') then -c -c Figure is a stand-alone accidental, so must be centered -c - if (ch1q .eq. '#') then - call addstr(sq//Figutq//nofaq(1:lnofa)// - * '{'//sq//'sharpfig}',16+lnofa,soutq,lsout) - else if (ch1q .eq. '-') then - call addstr(sq//Figutq//nofaq(1:lnofa)// - * '{'//sq//'flatfig}',15+lnofa,soutq,lsout) - else if (ch1q .eq. 'n') then - call addstr(sq//Figutq//nofaq(1:lnofa)// - * '{'//sq//'natfig}',14+lnofa,soutq,lsout) - end if - go to 2 - else -c -c Figure is an accidental followed by a number -c First put the accidental (offset to the left) -c - if (ch1q .eq. '#') then - call addstr(sq//Figutq// - * nofaq(1:lnofa)//'{'//sq//'fsmsh}', - * 13+lnofa,soutq,lsout) - else if (ch1q .eq. '-') then - call addstr(sq//Figutq// - * nofaq(1:lnofa)//'{'//sq//'fsmfl}', - * 13+lnofa,soutq,lsout) - else if (ch1q .eq. 'n') then - call addstr(sq//Figutq// - * nofaq(1:lnofa)//'{'//sq//'fsmna}', - * 13+lnofa,soutq,lsout) - end if -c -c Now put the number -c - call addstr(sq//Figutq//nofq(1:lnof)//'{'//ch2q//'}', - * 8+lnof,soutq,lsout) - endif - else if (ch1q .eq. '_') then -c -c Placeholder only (for lowering a figure). Don't do anything! -c - continue - else -c -c Figure is a single number, maybe with s after -c - call addstr(sq//Figutq//nofq(1:lnof)//'{', - * 6+lnof,soutq,lsout) - ch2q = figq(ic+1:ic+1) - if (ch2q .eq. 's') then -c -c Use a special character. Insert font call -c - ic = ic+1 - call addstr(sq//'ligfont',8,soutq,lsout) - end if - call addstr(ch1q//'}',2,soutq,lsout) -c call addstr(sq//Figutq//nofq(1:lnof)//'{'//ch1q//'}', -c * 8+lnof,soutq,lsout) - end if - if (ic .ge. 10) go to 2 - ic = ic+1 - nof = nof+4 - nofa = nofa+4 - go to 1 -2 continue - if (abs(offnsk) .gt. .0001) then - notexq = sq//'off{' - if (offnsk .lt. -9.995) then - write(notexq(6:11),'(f6.2)')offnsk - lnote = 11 - else if (offnsk.lt.-.995 .or. offnsk.gt.9.995) then - write(notexq(6:10),'(f5.2)')offnsk - lnote = 10 - else if (offnsk.lt.-.0001 .or. offnsk.gt..995) then - write(notexq(6:9),'(f4.2)')offnsk - lnote = 9 - else - write(notexq(6:8),'(f3.2)')offnsk - lnote = 8 - end if - notexq = notexq(1:lnote)//sq//'noteskip}' - call addstr(notexq,lnote+10,soutq,lsout) - end if - if (ifig .lt. nfigs(ivx)) then - ifig = ifig+1 - else - nfigs(ivx) = 0 - figcheck = .false. - end if - return - end - subroutine putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx, - * ncm,islur,nvmx,nv,ihornb,stemlin,outq,lout,ip,islhgt, - * beamon,iscrd) -c -c All args are individual array element *values* except nornb,ihornb,ulq. -c notcrd = .true. if ornament is on main note. -c nolevm is level of main note (for chords) -c - parameter (nm=24) - character*1 ulpzq,ulq(nm,9),udqq,sq,chax - character*8 noteq - character*79 notexq,outq - integer*4 ihornb(nm,24),nornb(nm) - logical btest,iscrd,usehornb,beamon - common /comivxudorn/ivxudorn(63) - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - sq = chax(92) - lout = 0 - usehornb = .false. - if (nodur .lt. 64) then - stemlen = stemlin - else - stemlen = 0. - end if -c -c Get up-downness. ulpzq is opposite from stem direction for both beams and -c non beams. Can use in name of ornament [ . or _ ] -c - if (beamon) then - if (ulq(ivx,ibmcnt) .eq. 'u') then - ulpzq = 'l' - else - ulpzq = 'u' - end if - else - if (udqq(nolevm,ncm,islur,nvmx,ivx,nv).eq.'l' ) then - ulpzq = 'u' - else - ulpzq = 'l' - end if - end if -c -c To enable >1 ornament on a note, next line is top of manual loop. -c -2 continue -c -c Bit # of last ornament (last of bits 0-21) -cc Bit # of last ornament (last of bits 0-24) - ibit = log2(iand(iornq,4194303)) -c ibit = log2(iand(iornq,33554431)) - iornt = 2**ibit -c -c Begin routine to set height. Bits 0-13: (stmgx+Tupf._) -c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n -c 19-20: >^, 21: ? (with or w/o 16-18) -c -c Do not use beam height for . or _ -c - if (btest(iornq,22) .and. iand(iornt,6144).eq.0) then -c -c Height is set by special beam stuff. -c Do not leave ihorn set, do separately for every ornament -c - ihorn = ihornb(ivx,nornb(ivx)) - if (ulpzq .eq. 'u') ihorn = ihorn-2 -c -c Following flag tells whether to increment nornb when exiting the subroutine. -c - usehornb = .true. - else if (ibit .eq. 14) then -c -c Down fermata. Don't worry about upper chord notes. -c - if (ulpzq .eq. 'l') then - ihorn = min(nolev,ncm-3) - else - ihorn = min(nolev-stemlen,ncm-3.) - end if - else if (btest(iornt,13) .or. btest(iornt,0)) then -c -c ( or ) -c - ihorn = nolev - else if (iand(iornt,6144) .gt. 0) then -c -cc Staccato . or tenuto _ , but not special beam stuff. Need up-down info -c NOTE: removed .&_ from special beam treatment. -c Staccato . or tenuto _ Need up-down info -c - if (.not.iscrd .or. (maxlev.ne.nolev.and.ulpzq.eq.'l') .or. - * (minlev.ne.nolev.and.ulpzq.eq.'u')) then - ihorn = nolev - else if (maxlev .eq. nolev) then - ulpzq = 'u' - ihorn = max(nolev+stemlen,ncm+3.) - else - ulpzq = 'l' - ihorn = min(nolev-stemlen,ncm-3.) - end if - else if (iscrd .and. nolev .eq. minlev) then - if (ulpzq .eq. 'l') then - ihorn = min(nolev-3,ncm-6) - else - ihorn = min(nolev-nint(stemlen)-3,ncm-6) - end if - else if (ibit.eq.10 .and. nolev.gt.90) then -c -c Special treatment for fermata on a shifted rest -c - ihorn = ncm+5 - else if (ulpzq.eq.'l') then -c -c (iscrd and nolev=maxlev) or (.not.iscrd) -c - ihorn = max(nolev+stemlen+2,ncm+5.) - else - ihorn = max(nolev+2,ncm+5) - end if - ioff = 0 - iclracc = 0 -c -c Begin routine to set name. Bits 0-13: (stmgx+Tupf._) -c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n -c - if (btest(iornt,2)) then - notexq = sq//'shake' - lnote = 6 - else if (btest(iornt,3)) then - notexq = sq//'mordent' - lnote = 8 - else if (btest(iornt,1)) then - notexq = sq//'mtr' - lnote = 4 - else if (btest(iornt,5)) then - notexq = sq//'xtr' - lnote = 4 - else if (btest(iornt,6)) then - notexq = sq//'ptr' - lnote = 4 - else if (btest(iornt,13)) then - notexq = sq//'rpn' - lnote = 4 - else if (btest(iornt,0)) then - notexq = sq//'lpn' - lnote = 4 - else if (btest(iornt,12)) then - notexq = sq//ulpzq//'st' - lnote = 4 - else if (btest(iornt,11)) then - notexq = sq//ulpzq//'pz' - lnote = 4 - else if (btest(iornt,8)) then - notexq = sq//'upz' - lnote = 4 - ioff = -2 - else if (btest(iornt,9)) then - notexq = sq//'uppz' - lnote = 5 - ioff = -2 - else if (btest(iornt,10)) then - if (nodur .lt. 48) then - notexq = sq//'fermataup' - else - notexq = sq//'Fermataup' - end if - lnote = 10 - ioff = -2 - else if (btest(iornt,14)) then - if (nodur .lt. 48) then - notexq = sq//'fermatadown' - else - notexq = sq//'Fermatadown' - end if - lnote = 12 - else if (btest(iornt,21)) then -c -c "?" in editorial ornament. Clear bit 16-18 after use, since ibit=21 -c - if (btest(iornq,16)) then - notexq = sq//'qsharp' - lnote = 7 - ioff = 2 - iornq = ibclr(iornq,16) - iclracc = 16 - else if (btest(iornq,17)) then - notexq = sq//'qflat' - lnote = 6 - ioff = 1 - iornq = ibclr(iornq,17) - iclracc = 17 - else if (btest(iornq,18)) then - notexq = sq//'qnat' - lnote = 5 - ioff = 2 - iornq = ibclr(iornq,18) - iclracc = 18 - else - notexq = sq//'qedit' - lnote = 6 - ioff = 0 - end if - else if (btest(iornt,16)) then - notexq = sq//'esharp' - lnote = 7 - ioff = 2 - else if (btest(iornt,17)) then - notexq = sq//'eflat' - lnote = 6 - ioff = 1 - else if (btest(iornt,18)) then - notexq = sq//'enat' - lnote = 5 - ioff = 2 - else if (btest(iornt,19)) then - notexq = sq//'usf' - lnote = 4 - ioff = -2 - else if (btest(iornt,20)) then - notexq = sq//'usfz' - lnote = 5 - ioff = -2 - end if - iudorn = 0 -c -c User-defined level shift of ornament from default? -c - if (btest(iornq,25)) then -c -c Find which (if any) element of kudorn has the shift. -c - do 3 iudorn = 1 , nudorn - if (ibit .lt. 21) then - ibitt = ibit -c -c Could have oes, but not oe? or oes? -c - else if (iclracc .gt. 0) then -c -c Earlier cleared edit. accid, meaning it was oes? -c - ibitt = iclracc+6 - else - ibitt = 21 - end if - ibitt=ip+ishft(mod(ivx,16),8)+ishft(nolev,12)+ishft(ibitt,19) -c if (ibitt .eq. iand(33554431,kudorn(iudorn))) go to 4 - if (ibitt .eq. iand(33554431,kudorn(iudorn)) - * .and. ivx.eq.ivxudorn(iudorn)) go to 4 -3 continue -c -c Nothing shifted on this note; exit this if block -c - iudorn = 0 - go to 5 -4 continue - ioffinc = iand(63,ishft(kudorn(iudorn),-25))-32 - if (ibit.eq.19 .and. ioffinc .lt. -7) then -c -c Convert usf to lsf. The reason has to do with positioning being impossile -c for some mysterious reason when you drop \usf below the staff -c - notexq = sq//'lsf' - ioffinc = ioffinc+6 - end if - ioff = ioff+ioffinc - end if -5 continue -c -c Shift level to avoid slur. Conditions are -c 1. There is a slur -c 2. No user-defined orn height shift (btest(iornq,25)) -c 3. upslur (islhgt>0) -c 4. ornament is not segno(4), ._)(11-13), down ferm(14) or "(" (0) Bin=30737 -c 5. islhgt+3 >= height already computed. -c - if (.not.btest(iornq,25) .and. - * islhgt.gt.0 .and. iand(iornt,30737).eq.0) - * ioff = ioff+dim(islhgt+3,ihorn ) - call notefq(noteq,lnoten,ihorn+ioff,ncm) - if (lnoten.eq.1) call addblank(noteq,lnoten) - if (iand(iornt,32896) .gt. 0) then -c -c T-trill or trill w/o "tr" -c - call dotrill(ivx,ip,iornt,noteq,lnoten,notexq,lnote) - else - notexq = notexq(1:lnote)//noteq(1:lnoten) - lnote = lnote+lnoten - end if - if (iudorn .gt. 0) then - if (btest(kudorn(iudorn),31)) then -c -c Horizontal shift -c - lform = lfmt1(ornhshft(iudorn)) - write(noteq(1:lform),'(f'//chax(48+lform)//'.1)') - * ornhshft(iudorn) - notexq = sq//'roffset{'//noteq(1:lform)//'}{' - * //notexq(1:lnote)//'}' - lnote = lnote+lform+12 - ornhshft(iudorn) = 0. - kudorn(iudorn) = ibclr(kudorn(iudorn),31) - end if - end if -c -c Zero out the bit for ornament just dealt with. -c - iornq = ibclr(iornq,ibit) - if (lout .eq. 0) then - outq = notexq(1:lnote) - else - outq = outq(1:lout)//notexq(1:lnote) - end if - lout = lout+lnote -c -c Check bits 0-21, go back if any are still set -c - if (iand(iornq,4194303) .gt. 0) go to 2 - if (usehornb) nornb(ivx) = nornb(ivx)+1 - return - end - subroutine putshft(ivx,onoff,soutq,lsout) - parameter (nm=24) - common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) - character*80 soutq,notexq - character*1 sq,chax - logical onoff - sq = chax(92) -c -c Start user-defined offsets X(...): or X(...)S -c - if (onoff) nudoff(ivx) = nudoff(ivx)+1 -c -c Xoff is in pts. Round off to nearest .1. Will use at end of shift. -c - xoff = udoff(ivx,nudoff(ivx)) - xoff = sign(int(10.*abs(xoff)+.5)/10.,xoff) - if (.not.onoff) xoff = -xoff - if (xoff .lt. -9.95) then - ifmt = 5 - else if (xoff.lt.-.95 .or. xoff.gt.9.95) then - ifmt = 4 - else - ifmt = 3 - end if - write(notexq,'(f'//chax(48+ifmt)//'.1)')xoff - call addstr(sq//'off{'//notexq(1:ifmt)//'pt}',8+ifmt, - * soutq,lsout) - return - end - subroutine puttitle(inhnoh,xnsttop,etatop,sq,etait,etatc, - * etacs1,nv,vshrink,sepsymq) -c -c Called once per page, at top of page! If vshrink, only called for p.1. -c Actual titles only allowed on p.1. (set by headlog). -c 3/18/01: The above comment is probably bogus...can use Tt on later pages. -c - common /comlast/ islast,usevshrink - logical islast,usevshrink - common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, - * inhead - common /cominbot/ inbothd - character*127 notexq - character*120 instrq,titleq,compoq - parameter (nm=24) - character*1 sq,sepsymq(nm),chax - logical headlog,vshrink - notexq = sq//'znotes' - lenline = 7 - do 22 iv = 1 , nv-1 - notexq = notexq(1:lenline)//sepsymq(iv) - lenline = lenline+1 -22 continue - notexq = notexq(1:lenline)//sq//'zcharnote{' - lenline = lenline+11 - if (.not.headlog) then - inhead = inhnoh - end if - if (vshrink .and. usevshrink) then - inhead = 16 - end if - ndig = int(alog10(inhead+.01))+1 - write(notexq(lenline+1:lenline+ndig+10),'(i'//chax(48+ndig)// - * ',a10)')inhead,'}{'//sq//'titles{' - lenline = lenline+ndig+10 -c -c Vertical skip at top of page (\Il) = etatop*glueil. Needed whether -c headers are present or not. -c - glueil = xnsttop/etatop - vskil = etatop*glueil - if (vshrink .and. usevshrink) vskil = 2 - call writflot(vskil,notexq,lenline) - if (.not.headlog) then - if (islast) write(11,'(a)')notexq(1:lenline) - * //'}{}{0}{}{0}{}{0}}'//sq//'en%' - else - notexq = notexq(1:lenline)//'}{' - lenline = lenline+2 - lcq = lenstr(instrq,120) - if (lcq .gt. 0) then - xitil = etait*glueil - if (vshrink .and. usevshrink) xitil = 2 - notexq = notexq(1:lenline)//instrq(1:lcq)//'}{' -c -c Null out instrument once used -c - instrq = ' ' - lenline = lenline+lcq+2 - call writflot(xitil,notexq,lenline) - else - notexq = notexq(1:lenline)//'}{0' - lenline = lenline+3 - end if - if (islast) write(11,'(a)')notexq(1:lenline)//'}%' - notexq = '{' - lenline = 1 - lcq = lenstr(titleq,120) - if (lcq .gt. 0) then - notexq = notexq(1:lenline)//titleq(1:lcq) - lenline = lenline+lcq - else - call printl(' ') - call printl('WARNING') - call printl( - * ' In a title block, you have specified instrument and/or') - call printl( - * ' composer but no title for the piece.') - end if - notexq = notexq(1:lenline)//'}{' - lenline = lenline+2 - xtcil = etatc*glueil - lcq = lenstr(compoq,120) - if (lcq .eq. 0) xtcil = 2*xtcil - if (vshrink .and. usevshrink) xtcil = 2 - call writflot(xtcil,notexq,lenline) - notexq = notexq(1:lenline)//'}{' - lenline = lenline+2 - if (lcq .gt. 0) then - notexq = notexq(1:lenline)//compoq(1:lcq)//'}{' - lenline = lenline+2+lcq -c -c Null out compoq so it does not get written later -c - compoq = ' ' - xcsil = etacs1*glueil - if (vshrink .and. usevshrink) xcsil = 2 - call writflot(xcsil,notexq,lenline) - else - notexq = notexq(1:lenline)//'}{0' - lenline = lenline+3 - end if - if (islast) write(11,'(a)')notexq(1:lenline)//'}}'//sq//'en%' - headlog = .false. - end if - return - end - subroutine putxtn(ntupv,iflop,multb,iud,wheadpt,poenom, - * nolev1,islope,slfac,xnlmid,islur,lnote,notexq,ncmid,nlnum, - * eloff,iup,irest,usexnumt) -c -c Places digit for xtuplet. -c - character*1 chax - character*8 noteq - character*79 notexq - logical btest,usexnumt - if (iflop.ne.0 .and. multb.gt.0) then -c -c Number goes on beam side, move R/L by .5 wheadpt for upper/lower -c - eloff = eloff-0.5*iud*wheadpt/poenom -c -c Number goes on beam side, must use beam parameters to set pos'n -c - nlnum = nolev1+islope/slfac*eloff+iup*(multb+8) - if (multb .ge. 2) nlnum = nlnum+iup - else - nlnum = nint(xnlmid-1+3*iud+iflop*11) - end if - if (.not.btest(islur,31)) then -c -c Only print number when wanted. First check vert, horiz offset -c - if (btest(irest,1)) nlnum = nlnum+iand(31,ishft(irest,-2))-16 - if (btest(irest,7)) eloff = eloff+ - * (.1*iand(31,ishft(irest,-9))-1.6)*wheadpt/poenom - if (.not.usexnumt) then - notexq = chax(92)//'xnum{' - lnote = 10 - istrtn = 7 - else - notexq = chax(92)//'xnumt{' - lnote = 11 - istrtn = 8 - end if - if (eloff .lt. 0.995) then - write(notexq(istrtn:istrtn+3),'(i1,f3.2)')0,eloff - else if (eloff .lt. 9.995) then - write(notexq(istrtn:istrtn+3),'(f4.2)')eloff - else - write(notexq(istrtn:istrtn+4),'(f5.2)')eloff - lnote = lnote+1 - end if - call notefq(noteq,lnoten,nlnum,ncmid) - notexq = notexq(1:lnote)//'}'//noteq(1:lnoten) - lnote = lnote+1+lnoten - if (ntupv .lt. 10) then - write(notexq(lnote+1:lnote+1),'(i1)')ntupv - lnote = lnote+1 - else - notexq = notexq(1:lnote)//'{' - write(notexq(lnote+2:lnote+3),'(i2)')ntupv - notexq = notexq(1:lnote+3)//'}' - lnote = lnote+4 - end if - end if - return - end - subroutine read10(string,lastchar) - parameter (maxblks=4000) - character*65536 bufq - integer*2 lbuf(maxblks) - common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq - character*(*) string - character*128 lnholdq - logical lastchar - common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac - logical mrecord,mplay,endmac - common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), - * ic1mac(20),ilmac,iplmac - if (.not.mplay) then - if (ilbuf .gt. nlbuf) go to 999 - call getbuf(string) - return -999 lastchar = .true. - return - else -c -c Play a macro. Set pointer to first character needed in buffer -c - if (ilmac .eq. il1mac(macnum)) then -c -c Getting first line of macro -c - ip1 = ip1mac(macnum) - iplmac = ip1-ic1mac(macnum) - else if (ilmac .le. il2mac(macnum)) then -c -c Beyond first line of macro. Advance line-start pointer. -c - iplmac = iplmac+lbuf(ilmac-1) - ip1 = iplmac+1 - else -c -c Beyond last line of macro. Terminate it! -c - mplay = .false. - endmac = .true. - return - end if - if (ilmac .eq. il2mac(macnum)) then -c -c Getting last line of macro. -c - ip2 = ip2mac(macnum) - else -c -c Getting line before last line of macro. -c - ip2 = iplmac+lbuf(ilmac) - end if - if (ip2 .ge. ip1) then - string = bufq(ip1:ip2) - else -c -c Kluge for when macro start is on a line by itself -c - string = ' ' - end if - ilmac = ilmac+1 - return - end if - end - function readin(lineq,iccount,nline) -c -c Reads a piece of setup data from file lineq, gets a new lineq from -c file 10 (jobname.pmx) and increments nline if needed, passes over -c comment lines -c - character*128 lineq - character*1 durq,chax -4 if (iccount .eq. 128) then -1 call getbuf(lineq) - nline = nline+1 - if (lineq(1:1) .eq. '%') go to 1 - iccount = 0 - end if - iccount = iccount+1 -c -c Find next non-blank or end of line -c - do 2 iccount = iccount , 127 - if (lineq(iccount:iccount) .ne. ' ') go to 3 -2 continue -c -c If here, need to get a new line -c - iccount = 128 - go to 4 -3 continue -c -c iccount now points to start of number to read -c - i1 = iccount -5 call getchar(lineq,iccount,durq) -c -c Remember that getchar increments iccount, then reads a character. -c - if (index('0123456789.-',durq) .gt. 0) go to 5 - i2 = iccount-1 - if (i2 .lt. i1) then - print*,'Found "'//durq//'" instead of number' - call stop1() - end if - icf = i2-i1+49 - read(lineq(i1:i2),'(f'//chax(icf)//'.0)')readin - return - end - subroutine readmeter(lineq,iccount,mtrnum,mtrden) - character*128 lineq - character*1 durq,chax - if (index(lineq(iccount+1:iccount+3),'/') .eq. 0) then -c -c No slashes, so use old method -c - call getchar(lineq,iccount,durq) - if (durq .eq. '-') then -c -c Negative numerator is used only to printed; signals vertical slash -c - call getchar(lineq,iccount,durq) - mtrnum = -(ichar(durq)-48) - else if (durq .eq. 'o') then -c -c Numerator is EXACTLY 1 -c - mtrnum = 1 - else - mtrnum = ichar(durq)-48 - if (mtrnum .eq. 1) then -c -c Numerator is >9 -c - call getchar(lineq,iccount,durq) - mtrnum = 10+ichar(durq)-48 - end if - end if - call getchar(lineq,iccount,durq) - if (durq .eq. 'o') then - mtrden = 1 - else - mtrden = ichar(durq)-48 - if (mtrden .eq. 1) then - call getchar(lineq,iccount,durq) - mtrden = 10+ichar(durq)-48 - end if - end if - else -c -c Expect the form m[n1]/[n2]/[n3]/[n4] . Advance iccount by one from '/' or 'm' -c - iccount = iccount+1 - ns = index(lineq(iccount:128),'/') - read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrnum -c -c Reset iccount to start of second integer -c - iccount = iccount+ns -c -c There must be either a slash or a blank at pos'n 2 or 3 -c - ns = index(lineq(iccount:iccount+2),'/') - if (ns .eq. 0) ns = index(lineq(iccount:iccount+2),' ') - read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrden -c -c Set iccount to last character used -c - iccount = iccount+ns-1 - end if - return - end - subroutine readnum(lineq,iccount,durq,fnum) -c -c This reads a number starting at position iccount. Remember that on exit, -c getchar leaves iccount at the last character retrieved. So must only -c call this routine *after* detecting a number or decimal. -c On exit, durq is next character after end of number. -c - character*128 lineq - character*1 durq,chax - i1 = iccount -1 call getchar(lineq,iccount,durq) - if (index('0123456789.',durq) .gt. 0) go to 1 - i2 = iccount-1 - if (i2 .lt. i1) then - print*,'Found "'//durq//'" instead of number' - call stop1() - else if (lineq(i1:i1).eq.'.'.and.lineq(i2:i2).eq.'.') then - i2 = i2-1 - iccount = iccount-1 - end if - icf = i2-i1+49 - read(lineq(i1:i2),'(f'//chax(icf)//'.0)')fnum - return - end - subroutine setbits(isdata,iwidbit,ishift,ivalue) -c -c Sets iwidbits of isdata, shifted by ishift, to ivalue -c - ibase = 2**iwidbit-1 - if (ivalue.gt.ibase) then - print* - print*,'WARNING in setbits: ivalue > ibase' - write(15,'(/,a)')'WARNING in setbits: ivalue > ibase' - end if - isdata = iand(not(ishft(ibase,ishift)),isdata) - isdata = ior(isdata,ishft(ivalue,ishift)) - return - end - subroutine setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1) -c -c The MEAN SQUARE slope algorithm -c - parameter (nm=24) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - character*1 ulq,sepsymq,sq - logical beamon,firstgulp,figbass,figchk, - * isfig - real*4 xelsk(24) - integer ipb(24) - ibc = ibmcnt(ivx) - sumxx = 0. - sumxy = 0. - do 2 inb = 1 , nnb - sumxx = sumxx+xelsk(inb)**2 - sumxy = sumxy+xelsk(inb)*nolev(ivx,ipb(inb)) -2 continue - delta = nnb*sumxx-sumx*sumx - em = (nnb*sumxy-sumx*sumy)/delta - islope = nint(0.5*em*slfac) - if (iabs(islope) .gt. 9) islope = isign(9,islope) - beta = (sumy-islope/slfac*sumx)/nnb - nolev1 = nint(beta) -c -c Check if any stems are too short -c - smin = 100. - iul = -1 - if (ulq(ivx,ibc) .eq. 'u') iul = 1 - do 4 inb = 1 , nnb - ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac - ynote = nolev(ivx,ipb(inb)) - smin = min(smin,iul*(ybeam-ynote)) -4 continue - if (smin .lt. stemmin) then - deficit = stemmin-smin - nolev1 = nint(nolev1+iul*deficit) - end if - return - end - subroutine setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq, - * ivx,nline) - character*1 charq,durq - common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac - logical mrecord,mplay,endmac,btest - character*128 lnholdq,lineq - common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), - * ic1mac(20),ilmac,iplmac -c -c Macro action -c - call g1etchar(lineq,iccount,charq) - if (charq.eq.'S' .and. ivx.ne.1) then - print* - print* - print*,'*********WARNING*********' - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * '"MS..." only put in parts by scor2prt if in voice #1!') - end if - if (index('RSP ',charq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Illegal character after "M" (macro)!') - call stop1() - else if (charq .ne. ' ') then -c -c Record or playback a macro. Get the number of the macro. -c - call g1etchar(lineq,iccount,durq) - if (index('123456789',durq) .eq. 0) then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Must input number after "MR","MP", or "MS"!') - call stop1() - end if - call readnum(lineq,iccount,durq,fnum) - macnum = nint(fnum) - if (durq .ne. ' ') then - call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, - * 'Macro number must be followed by a blank!') - call stop1() - end if - if (index('RS',charq ).gt. 0) then -c -c Record or save a macro -c - if (macnum.lt.1 .or. macnum.gt.20) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Macro number not in range 1-20!') - call stop1() -c else if (btest(macuse,macnum)) then -c print* -c print*,'WARNING: Redefining macro # ',macnum - end if - macuse = ibset(macuse,macnum) - if (charq .eq. 'R') then - call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) - else if (charq .eq. 'S') then -c -c Save (Record but don't activate) -c -1 call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) - if (mrecord) then - call getbuf(lineq) - nline = nline+1 - iccount = 0 - go to 1 - end if - iccount = iccount+ndxm+1 - end if - else -c -c Playback the macro -c - if (.not.btest(macuse,macnum)) then - call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, - * 'Cannot play a macro that has not been recorded!') - call stop1() - end if - icchold = iccount - lnholdq = lineq - iccount = 128 - mplay = .true. - ilmac = il1mac(macnum) - end if - end if - return - end - subroutine setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) -c -c Sets last 2 args depending on 1st 2, (logical) num, denom. -c ibmtyp = 1, 2, or 3 defines set of masks for beam groupings. -c 1: all duple meters -c 2: triple w/ denom=4, subdivide in groups of 2 8ths -c 3: triple w/ denom=8, subdivide in groups of 3 8ths -c Note that lenbar is set at top or when 'm' symbol is read in getnote -c - if (mtrdenl .eq. 4) then - if (mod(mtrnuml,3) .eq. 0) then - ibmtyp = 2 - ibmrep = mtrnuml/3 - else - ibmtyp = 1 - ibmrep = mtrnuml/2 - end if - else if (mtrdenl .eq. 2) then - ibmtyp = 1 - if (mtrnuml .eq. 3) then - ibmrep = 3 - else - ibmrep = 2*mtrnuml/mtrdenl - end if - else -c -c Assumes mtrdenl=8 and 3/8, 6/8, 9/8, or 12/8 -c - ibmtyp = 3 - ibmrep = mtrnuml/3 - end if -c -c Reset so we don't keep writing new meters -c - mtrnuml = 0 -c -c Prevent ibmrep=0. Needed for odd bars, e.g. 1/8, where beams don't matter -c - ibmrep = max(ibmrep,1) - return - end - subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest) -c -c The outer combo algorithm -c - parameter (nm=24) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - common /comipl2/ ipl2(nm,200) - character*1 ulq,sepsymq,sq - logical beamon,firstgulp,figbass,figchk,btest, - * isfig,vxtup,l1ng,l2ng,bar1syst,drawbm - common /comeskz2/ eskz2(nm,200) - real*4 slope(800),xelsk(24) - integer ipb(24) - common /comask/ bar1syst,fixednew,scaldold, - * wheadpt,fbar,poenom - common /comas1/ naskb,task(40),wask(40),elask(40) - common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), - * mtupv(nm,9),nxtinbm(nm), - * islope(nm),xels11(24),eloff(nm,9), - * nssb(nm),issb(nm),lev1ssb(nm,20) - common /comdraw/ drawbm(nm) - common /combmh/ bmhgt,clefend - common /commvl/ nvmx(nm),ivmx(nm,2),ivx - common /comtol/ tol - ibc = ibmcnt(ivx) - nxtinbm(ivx) = 0 - n1 = ipl2(ivx,ibm1(ivx,ibc)) -c -c Initialize counters used in this subroutine, and then later during actual -c beam drawing, to count later segments of single-slope beam groups -c - nssb(ivx) = 0 - issb(ivx) = 0 -c -c Set flag for xtup beam starting with rest (no others can start with rest) -c - if (btest(irest(ivx,ipo(n1)),0)) ixrest = 1 -c -c Figure how many elemskips to each note. Use the list, counting only non-rests. -c - eskz0 = eskz(ivx,ibm1(ivx,ibc)) - nnb = 0 - sumx = 0. - sumy = 0. - ipxt1 = 0 - iplast = ibm2(ivx,ibc) - do 2 ip = ibm1(ivx,ibc) , iplast - if (.not.btest(irest(ivx,ip),0)) then - nnb = nnb+1 - ipb(nnb) = ip - xelsk(nnb) = eskz(ivx,ip)-eskz0 - sumx = sumx+xelsk(nnb) - sumy = sumy+nolev(ivx,ipb(nnb)) - if (btest(nacc(ivx,ip),21)) then -c -c This is the starting note of later segment of single-slope beam group -c Temporarily store ip here. -c - nssb(ivx) = nssb(ivx)+1 - lev1ssb(ivx,nssb(ivx)) = nnb - end if - end if -c -c New xtup stuff here. Final object is to get distance from start of xtup -c to number. xtinbm counts xtups in this beam only. mtupv is the printed -c number. ntupv is number of notes in xtup, and is only used to get -c eloff, the distance from start of xtup to the number. -c - if (btest(nacc(ivx,ip),18)) ndoub = ndoub+1 - if (ipxt1.eq.0 .and. nodur(ivx,ip).eq.0) then -c -c Xtup is starting here -c - nxtinbm(ivx) = nxtinbm(ivx)+1 - ipxt1 = ip - if (btest(nacc(ivx,ip),18)) then - ndoub = 1 - else - ndoub = 0 - end if - else if (ipxt1.gt.0 .and. nodur(ivx,ip).gt.0) then -c -c Xtup ends here. Set total number of notes in xtup. -c - ntupv(ivx,nxtinbm(ivx)) = ip+1-ipxt1 -c -c Set printed number for embedded xtup. -c - mtupv(ivx,nxtinbm(ivx)) = ntupv(ivx,nxtinbm(ivx))+ndoub -c -c Middle note of xtup if ntupv odd, note to left of gap if even. -c - ipxtmid = (ip+ipxt1)/2 - eloff(ivx,nxtinbm(ivx)) = eskz2(ivx,ipxtmid)-eskz2(ivx,ipxt1) - if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) - * eloff(ivx,nxtinbm(ivx)) = eloff(ivx,nxtinbm(ivx))+ - * .5*(eskz2(ivx,ipxtmid+1)-eskz2(ivx,ipxtmid)) - ipxt1 = 0 - end if -2 continue -c -c Reset nxtinbm for use as counter as #'s are posted by putxtn(..) -c - nxtinbm(ivx) = 0 - smed = 0. - if (.not.btest(islur(ivx,ipb(1)),2)) then -c -c No forced 0 slope -c - if (nnb .eq. 1) go to 6 - nsc = 0 - do 5 inb = 1 , nnb-1 - do 5 jnb = inb+1 , nnb - nsc = nsc+1 - slope(nsc) = (nolev(ivx,ipb(jnb))-nolev(ivx,ipb(inb)))/ - * (xelsk(jnb)-xelsk(inb)) - if (abs(slope(nsc)) .lt. 1.e-4) then - nsc = nsc+1 - slope(nsc) = slope(nsc-1) - nsc = nsc+1 - slope(nsc) = slope(nsc-1) - end if -5 continue - if (nsc .eq. 1) then - smed = slope(1) - go to 6 - end if - nscmid = nsc/2+1 - do 7 i = 1 , nscmid - do 7 j = i+1 , nsc - if (slope(j) .lt. slope(i)) then - t = slope(j) - slope(j) = slope(i) - slope(i) = t - end if -7 continue - smed = slope(nscmid) - if (nsc .eq. 2*(nsc/2)) then -c -c Even number of slopes in the list, so median is ambiguous -c - if (abs(slope(nscmid-1)) .lt. abs(slope(nscmid))-tol) then -c -c Lower-numbered one is truly less in absolute value, so use it -c - smed=slope(nscmid-1) - else if (abs(slope(nscmid-1)+slope(nscmid)) .lt. tol) then -c -c Two slopes are effectively equal. Take the one with sign of the average -c - sum = 0. - do 1 i = 1 , nsc - sum = sum+slope(i) -1 continue - smed = sign(smed,sum) - end if - end if -6 continue - islope(ivx) = nint(0.5*smed*slfac) - if (iabs(islope(ivx)) .gt. 9) - * islope(ivx) = isign(9,islope(ivx)) - else -c -c Forced horizontal beam -c - islope(ivx) = 0 - end if - beta = (sumy-islope(ivx)/slfac*sumx)/nnb -c -c If ixrest>0, this is a virtual nolev1 at location of rest. Will first use -c as is for placing xtup number and/or bracket, then reset it for start of -c actual beam -c - nolev1(ivx) = nint(beta) -c -c Check if any stems are too short -c - smin = 100. - iul = -1 - if (ulq(ivx,ibc) .eq. 'u') iul = 1 - ssq = 0. - syb = 0. -c yb1 = nolev1(ivx)+iul*(stemlen+bmhgt*(mult(ivx,ipb(1))-1)) - yb1 = nolev1(ivx) - * +iul*(stemlen+bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1)) - do 4 inb = 1 , nnb - ybeam = yb1+islope(ivx)*xelsk(inb)/slfac -c * -iul*bmhgt*(mult(ivx,ipb(inb))-1) - * -iul*bmhgt*(iand(15,mult(ivx,ipb(inb)))-8-1) - syb = syb+ybeam - ynote = nolev(ivx,ipb(inb)) - off = ybeam-ynote - if (inb .eq. 1) then - off1 = off - else if (inb .eq. nnb) then - off2 = off - end if - ssq = ssq+off*off - smin = min(smin,iul*off) -4 continue - dnolev = 0. - if (smin .lt. stemmin) then - deficit = stemmin-smin - nolevo = nolev1(ivx) - nolev1(ivx) = nint(nolev1(ivx)+iul*deficit) - dnolev = nolev1(ivx)-nolevo - off1 = off1+dnolev - off2 = off2+dnolev - end if - ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2 - if (.not.vxtup(ivx) .and. sqrt(ssq/nnb) .gt. stemmax .and. - * (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax) - * .and. .not.btest(islur(ivx,ipb(1)),2)) then -c -c The first check is to save trouble of putting xtup's in setbm2. -c The penultimate check is that first and last stems aren't both excessive. -c The last check is that a 0 slope has not been forced -c - call setbm2(xelsk,nnb,sumx,sumy,ipb,islope(ivx),nolev1(ivx)) - end if -c -c Check if beam starts or ends too high or low. -c -c xboff = bmhgt*(mult(ivx,ipb(1))-1) - xboff = bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1) - l1ng = iul*(nolev1(ivx)-ncmid(iv,ipb(1)))+xboff+7 .lt. 0. - xnolev2 = nolev1(ivx)+islope(ivx)/slfac*xelsk(nnb) - l2ng = iul*(xnolev2-ncmid(iv,ipb(nnb)))+xboff+7 .lt. 0 - if (l1ng .or. l2ng) then -c -c Need to correct start or stop, also slope -c - if (l1ng) then - nolev1(ivx) = nint(ncmid(iv,ipb(1))-(7.+xboff)*iul) - end if - if (l2ng) then - xnolev2 = nint(ncmid(iv,ipb(nnb))-(7.+xboff)*iul) - end if -c -c Since one or the other end has changed, need to change slope -c - if (.not.btest(islur(ivx,ipb(1)),2)) - * islope(ivx) = nint(slfac*(xnolev2-nolev1(ivx))/xelsk(nnb)) - end if - if (nssb(ivx) .gt. 0) then -c -c This is a single-slope beam group. Store start heights for later segs. -c - do 3 issbs = 1 , nssb(ivx) - lev1ssb(ivx,issbs) = nolev1(ivx)+islope(ivx)/slfac* - * xelsk(lev1ssb(ivx,issbs)) -3 continue - end if - return - end - subroutine sortpoe(nsyst,poe,ipoe) - parameter (nks=125) - real*4 poe(nks) - integer*4 ipoe(nks) -c -c Initialize ipoe: -c - do 3 iord = 1 , nsyst - ipoe(iord) = iord -3 continue -c -c Construct ipoe vector with pairwise interchanges. When done, ipoe(1) will -c be index of smallest poe, and ipoe(nsyst) will be index of biggest poe. -c - do 4 io1 = 1 , nsyst-1 - do 5 io2 = io1+1 , nsyst - if (poe(ipoe(io1)) .gt. poe(ipoe(io2))) then -c -c Interchange the indices -c - itemp = ipoe(io1) - ipoe(io1) = ipoe(io2) - ipoe(io2) = itemp - end if -5 continue -4 continue - return - end - subroutine spsslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3, - * isdat4,nsdat,notcrd,nolev,starter) - parameter (nm=24) -c -c Reads in slur data. Record all h/v-shifts for non-chords, user-specified -c ones for chords. -c 5/26/02 This subr is called ONLY for postscript slurs. -c -c See subroutine doslur for bit values in isdat1,2,3 -c - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) - logical notcrd,btest - character*128 lineq - character*1 durq,dumq,starter - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - logical upslur,fontslur,WrotePsslurDefaults -c -c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve -c - numint = 0 - ivoff = 0 - ihoff = 0 - nsdat = nsdat+1 - if (starter.eq.'{' .or. starter.eq.'}') - * isdat2(nsdat)=ibset(isdat2(nsdat),3) - call setbits(isdat1(nsdat),5,13,iv) - call setbits(isdat1(nsdat),1,12,kv-1) - call setbits(isdat1(nsdat),8,3,ip) - isdat3(nsdat) = 0 - isdat4(nsdat) = 0 - ilb12 = 0 ! flag for tweaks of 1st or 2nd (0|1) seg of linebreak slur -c -c Get ID code -c - call getchar(lineq,iccount,durq) - if (index('uldtb+-hfnHps ',durq) .gt. 0) then -c -c Null id. Note for ps slurs, 'H' cannot be an ID -c - iccount = iccount-1 - if (lineq(iccount:iccount) .eq. 't') then - idcode = 1 - else - idcode = 32 - end if - else -c -c Set explicit idcode -c - idcode = ichar(durq) - if (lineq(iccount-1:iccount-1) .eq. 't') then -c -c Make t[ID] look like s[ID]t -c - isdat2(nsdat) = ibset(isdat2(nsdat),3) - end if - end if - call setbits(isdat1(nsdat),7,19,idcode) -c -c Set start/stop: look thru list from end for same idcode,iv,kv -c - do 2 isdat = nsdat-1 , 1 , -1 - if (idcode .eq. igetbits(isdat1(isdat),7,19) .and. - * iv .eq. igetbits(isdat1(isdat),5,13) .and. - * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then -c -c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. -c - if (btest(isdat1(isdat),11)) go to 3 -c -c Found slur is a turnoff, so new one is a turnon. Jump down to set bit -c - go to 4 - end if -2 continue -c -c If here, this is turnon. -c -4 continue - isdat1(nsdat) = ibset(isdat1(nsdat),11) -3 continue -c -c Now done with initial turnon- or turnoff-specifics. -c - if (nint(SlurCurve).ne.0 .and. btest(isdat1(nsdat),11)) then -c -c There's a default curvature tweak -c - icurv1 = nint(SlurCurve)+3 - if (icurv1 .eq. 2) icurv1 = 1 - isdat3(nsdat) = ibset(isdat3(nsdat),0) - call setbits(isdat3(nsdat),6,2,32+icurv1) - end if -c -c Loop for rest of input -c -1 call getchar(lineq,iccount,durq) - if (index('uld',durq) .gt. 0) then -c -c Force direction -c - isdat1(nsdat) = ibset(isdat1(nsdat),26) - if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27) - go to 1 - else if (index('+-',durq) .gt. 0) then - numint = numint+1 - if (numint .eq. 1) then -c -c Vertical offset -c - iccount = iccount+1 - call readnum(lineq,iccount,dumq,fnum) - iccount = iccount-1 - ivoff = nint(fnum) - if (durq .eq. '-') ivoff = -ivoff - else if (numint .eq. 2) then -c -c Horizontal offset -c - iccount = iccount+1 - call readnum(lineq,iccount,dumq,fnum) - iccount = iccount-1 -c -c fnum is abs(hshift), must be 0 to 6.3 -c - ihoff = fnum*10 + .5 - if (durq .eq. '-') ihoff = -ihoff -c -c Later will set bits to 1...127 to represent -6.3,...+6.3 -c - else -c -c Must be the 3rd signed integer, so it's a curve specification -c - isdat3(nsdat) = ibset(isdat3(nsdat),0) - iccount = iccount+1 - call readnum(lineq,iccount,dumq,fnum) - icurv1 = nint(fnum) - if (durq .eq. '-') icurv1 = -icurv1 - call setbits(isdat3(nsdat),6,2,32+icurv1) - if (dumq .ne. ':') then -c -c Back up the pointer and loop for more input -c - iccount = iccount-1 - else -c -c Expect two single digits as parameters for curve -c - isdat3(nsdat) = ibset(isdat3(nsdat),1) - call setbits(isdat3(nsdat),3,8, - * ichar(lineq(iccount+1:iccount+1))-48) - call setbits(isdat3(nsdat),3,11, - * ichar(lineq(iccount+2:iccount+2))-48) - iccount = iccount+2 - end if - end if - go to 1 - else if (durq .eq. 't') then - isdat2(nsdat) = ibset(isdat2(nsdat),3) - go to 1 - else if (durq .eq. 'b') then - isdat2(nsdat) = ibset(isdat2(nsdat),4) - go to 1 - else if (durq .eq. 's') then -c -c Endpoint tweaks for linebreak slurs. -c - call getchar(lineq,iccount,durq) ! Must be +|- -c -c Next is vertical offset -c - iccount = iccount+1 - call readnum(lineq,iccount,dumq,fnum) - if (durq .eq. '-') fnum=-fnum - call setbits(isdat4(nsdat),6,ilb12*16,nint(fnum)+32) - if (index('+-',dumq) .gt. 0) then -c -c Also a horizontal offset -c - iccount = iccount+1 - call readnum(lineq,iccount,durq,fnum) - if (dumq .eq. '-') fnum=-fnum - call setbits(isdat4(nsdat),7,ilb12*16+6,nint(10*fnum)+64) - end if - iccount = iccount-1 - ilb12 = 1 - go to 1 - else if (index('fnhH',durq).gt.0) then -c -c Special ps slur curvatures. -c Translate to old \midslur args (1,4,5,6) -c - icurv1 = index('fnxhH',durq) - if (icurv1 .eq. 5) then -c -c check for 2nd H -c - if (lineq(iccount+1:iccount+1) .eq. 'H') then - iccount = iccount+1 - icurv1 = 6 - end if - end if - isdat3(nsdat) = ibset(isdat3(nsdat),0) - call setbits(isdat3(nsdat),6,2,32+icurv1) - go to 1 - else if (durq .eq. 'p') then ! Local adjustment - call getchar(lineq,iccount,durq) ! +|- - call getchar(lineq,iccount,dumq) ! s|t -c 26 \sluradjust (p+s) -c 27 \nosluradjust (p-s) -c 28 \tieadjust (p+t) -c 29 \notieadjust (p-t) - if (durq .eq. '+') then - if (dumq .eq. 's') then - isdat2(nsdat) = ibset(isdat2(nsdat),26) - else - isdat2(nsdat) = ibset(isdat2(nsdat),28) - end if - else - if (dumq .eq. 's') then - isdat2(nsdat) = ibset(isdat2(nsdat),27) - else - isdat2(nsdat) = ibset(isdat2(nsdat),29) - end if - end if - go to 1 - end if -c -c Record shifts -c - call setbits(isdat2(nsdat),6, 6,ivoff+32) - call setbits(isdat2(nsdat),7,12,ihoff+64) -c -c Record chord flag, note level, notehead shift -c - if (notcrd) then - call setbits(isdat2(nsdat),7,19,nolev) - else - nolevc = igetbits(icrdat(ncrd),7,12) - call setbits(isdat2(nsdat),7,19,nolevc) - isdat2(nsdat) = ibset(isdat2(nsdat),0) - call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23)) - end if - return - end - subroutine sslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3, - * nsdat,notcrd,nolev,starter) - parameter (nm=24) -c -c Reads in slur data. Record all h/v-shifts for non-chords, user-specified -c ones for chords. -c 5/26/02 now only for non-postscript slurs, use spsslur() for postscript -c -c See subroutine doslur for bit values in isdat1,2,3 -c - common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), - * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, - * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 - integer*4 isdat1(202),isdat2(202),isdat3(202) - logical notcrd,btest - character*128 lineq - character*1 durq,dumq,starter - common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur - * ,WrotePsslurDefaults,SlurCurve - logical upslur,fontslur,WrotePsslurDefaults -c -c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve -c - numint = 0 - ivoff = 0 - ihoff = 0 - nsdat = nsdat+1 - if (starter.eq.'{' .or. starter.eq.'}') - * isdat2(nsdat)=ibset(isdat2(nsdat),3) - call setbits(isdat1(nsdat),5,13,iv) - call setbits(isdat1(nsdat),1,12,kv-1) - call setbits(isdat1(nsdat),8,3,ip) - isdat3(nsdat) = 0 -c -c Get id letter -c - if (lineq(iccount:iccount) .eq. 't') then -c -c Old-style t-slur. Use special idcode = 1 -c - idcode = 1 - else - call getchar(lineq,iccount,durq) - if (index('uldtb+-hf ',durq) .gt. 0) then -c -c Null id -c - idcode = 32 - iccount = iccount-1 - else if (durq.eq.'H') then -c -c Postscript slur, cannot use 'H' as code, must check for 2nd 'H' -c - idcode = 32 - iccount = iccount-1 -c -c There may be another "H", but no need to deal with it yet -c - else -c -c Set explicit idcode -c - idcode = ichar(durq) - end if - end if - call setbits(isdat1(nsdat),7,19,idcode) -c -c Set start/stop: look thru list from end for same idcode,iv,kv -c - do 2 isdat = nsdat-1 , 1 , -1 - if (idcode .eq. igetbits(isdat1(isdat),7,19) .and. - * iv .eq. igetbits(isdat1(isdat),5,13) .and. - * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then -c -c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. -c - if (btest(isdat1(isdat),11)) go to 3 -c -c Found slur is a turnoff, so new one is a turnon. Jump down to set bit -c - go to 4 - end if -2 continue -c -c If here, this is turnon. -c -4 continue - isdat1(nsdat) = ibset(isdat1(nsdat),11) -3 continue -c -c Now done with initial turnon- or turnoff-specifics. Loop for rest of input -c -1 call getchar(lineq,iccount,durq) - if (index('uld',durq) .gt. 0) then -c -c Force direction -c - isdat1(nsdat) = ibset(isdat1(nsdat),26) - if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27) - go to 1 - else if (index('+-',durq) .gt. 0) then - numint = numint+1 - if (numint .eq. 1) then -c -c Vertical offset -c - iccount = iccount+1 - call readnum(lineq,iccount,dumq,fnum) - iccount = iccount-1 - ivoff = nint(fnum) - if (durq .eq. '-') ivoff = -ivoff - else if (numint .eq. 2) then -c -c Horizontal offset -c - iccount = iccount+1 - call readnum(lineq,iccount,dumq,fnum) - iccount = iccount-1 -c -c fnum is abs(hshift), must be 0 to 6.3 -c - ihoff = fnum*10 + .5 - if (durq .eq. '-') ihoff = -ihoff -c -c Later will set bits to 1...127 to represent -6.3,...+6.3 -c - else -c -c Must be the 3rd signed integer, so it's a curve specification -c - isdat3(nsdat) = ibset(isdat3(nsdat),0) - iccount = iccount+1 - call readnum(lineq,iccount,dumq,fnum) - icurv1 = nint(fnum) - if (durq .eq. '-') icurv1 = -icurv1 - call setbits(isdat3(nsdat),6,2,32+icurv1) - if (dumq .ne. ':') then -c -c Back up the pointer and loop for more input -c - iccount = iccount-1 - else -c -c Expect two single digits as parameters for curve -c - isdat3(nsdat) = ibset(isdat3(nsdat),1) - call setbits(isdat3(nsdat),3,8, - * ichar(lineq(iccount+1:iccount+1))-48) - call setbits(isdat3(nsdat),3,11, - * ichar(lineq(iccount+2:iccount+2))-48) - iccount = iccount+2 - end if - end if - go to 1 - else if (durq .eq. 't') then - isdat2(nsdat) = ibset(isdat2(nsdat),3) - go to 1 - else if (durq .eq. 'b') then - isdat2(nsdat) = ibset(isdat2(nsdat),4) - go to 1 - else if (index('fhH',durq) .gt. 0) then -c -c Special ps slur curvatures. Translate to old \midslur args (1,4,5,6) -c - icurv1 = 2+index('fhH',durq) - if (icurv1 .eq. 3) then - icurv1 = 1 - else if (icurv1 .eq. 5) then -c -c check for 2nd H -c - if (lineq(iccount+1:iccount+1) .eq. 'H') then - iccount = iccount+1 - icurv1 = 6 - end if - end if - isdat3(nsdat) = ibset(isdat3(nsdat),0) -c -c Must change sign if downslur, but cannot do it now since we don't know -c slur direction for sure. -c - call setbits(isdat3(nsdat),6,2,32+icurv1) - go to 1 - end if -c -c Record shifts -c - call setbits(isdat2(nsdat),6, 6,ivoff+32) - call setbits(isdat2(nsdat),7,12,ihoff+64) -c -c Record chord flag, note level, notehead shift -c - if (notcrd) then - call setbits(isdat2(nsdat),7,19,nolev) - else - nolevc = igetbits(icrdat(ncrd),7,12) - call setbits(isdat2(nsdat),7,19,nolevc) - isdat2(nsdat) = ibset(isdat2(nsdat),0) - call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23)) - end if - return - end - subroutine stop1() - call exit(1) - end - subroutine topfile(basenameq,lbase,nv,clefq,noinst,musicsize, - * xinstf1,mtrnmp,mtrdnp,vshrink,fbar,fontslur) - parameter (nm=24) - common /comlast/ islast,usevshrink - logical islast,usevshrink,fontslur - common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, - * isig,lastisig,fracindent,widthpt,height,idsig, - * lnam(nm),inameq(nm) - common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), - * xinsnow,lowdot - common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) - character*79 inameq - character*44 basenameq - character*24 fmtq - character*5 fbarq - character*1 clefq(nm),sq,chax - common /comstart/ facmtr - logical vshrink,lowdot,rename - logical novshrinktop,cstuplet - common /comnvst/ novshrinktop,cstuplet - common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), - * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans - logical EarlyTransOn,LaterInstTrans - common /comsize/ isize(nm) - sq = chax(92) - vshrink = xinstf1.gt.20. .and. .not.novshrinktop - if (vshrink) then - xinsnow = 10. - else - xinsnow = xinstf1 - end if - if (.not.islast) return - write(11,'(a)')'%%%%%%%%%%%%%%%%%' - write(11,'(a)')'%' - write(11,'(a)')'% '//basenameq(1:lbase)//'.tex' - write(11,'(a)')'%' - write(11,'(a)')'%%%%%%%%%%%%%%%%' - write(11,'(a)')sq//'input musixtex' - write(11,'(a)')sq//'input pmx' -c write(11,'(a)')sq//'input musixmad' -c write(11,'(a)')sq//'input musixxad' - write(11,'(a)') - * sq//'setmaxslurs{24}'//sq//'setmaxinstruments{24}%' - if (.not.fontslur) write(11,'(a)')sq//'input musixps' -c -c Need to input musixmad to permit more slurs. -c - if (musicsize .eq. 20) then - write(11,'(a)')sq//'normalmusicsize%' - else if (musicsize .eq. 16) then - write(11,'(a)')sq//'smallmusicsize%' - else if (musicsize .eq. 24) then - write(11,'(a)')sq//'largemusicsize%' - write(11,'(a)')sq//'def'//sq//'meterfont{'//sq// - * 'meterlargefont}%' - else if (musicsize .eq. 29) then - write(11,'(a)')sq//'Largemusicsize%' - write(11,'(a)')sq//'def'//sq//'meterfont{'//sq// - * 'meterLargefont}%' - end if -c -c Set sizes. Have sizes per staff in isize(.) and noinst per staff in -c nsperi(.) -c - iiv = 1 - do 5 iinst = 1 , noinst - if (isize(iiv) .eq. 1) then - if(iinst.le.9) then - write(11,'(a8,i1,a)') - * sq//'setsize',iinst,sq//'smallvalue%' - else - write(11,'(a9,i2,a)') - * sq//'setsize{',iinst,'}'//sq//'smallvalue%' - end if - else if (isize(iiv) .eq. 2) then - if(iinst.le.9) then - write(11,'(a8,i1,a)') - * sq//'setsize',iinst,sq//'tinyvalue%' - else - write(11,'(a9,i2,a)') - * sq//'setsize{',iinst,'}'//sq//'tinyvalue%' - end if - end if - iiv = iiv+nsperi(iinst) -5 continue -c -c do 5 iiv = 1 , nv -c if (isize(iiv) .eq. 1) then -c if(iiv.le.9) then -c write(11,'(a8,i1,a)') -c * sq//'setsize',iiv,sq//'smallvalue%' -c else -c write(11,'(a9,i2,a)') -c * sq//'setsize{',iiv,'}'//sq//'smallvalue%' -c end if -c else if (isize(iiv) .eq. 2) then -c if(iiv.le.9) then -c write(11,'(a8,i1,a)') -c * sq//'setsize',iiv,sq//'tinyvalue%' -c else -c write(11,'(a9,i2,a)') -c * sq//'setsize{',iiv,'}'//sq//'tinyvalue%' -c end if -c end if -c5 continue -c - write(fbarq,'(f5.3)')fbar - write(11,'(a)')sq//'nopagenumbers' - write(11,'(a)')sq//'tracingstats=2'//sq//'relax' - write(11,'(a7,i3,a2)')sq//'hsize=',nint(widthpt),'pt' - write(11,'(a6,i'//chax(49+int(log10(height+.1)))//',a2)') - * sq//'vsize',int(height+.1),'pt' -c -c The default raisebarno=3.5 internote, set in pmx.tex. Increase to 4.5 if -c 3 sharps and treble clef, to avoid vertical clash with top space g# -c - if (isig.eq.3 .and. clefq(nv).eq.'t') write(11,'(a)') - * sq//'def'//sq//'raisebarno{4.5'//sq//'internote}' - if (noinst .lt. 10) then - write(11,'(a19,i1,a1)')sq//'def'//sq//'nbinstruments{', - * noinst,'}' - else - write(11,'(a19,i2,a1)')sq//'def'//sq//'nbinstruments{', - * noinst,'}' - end if - iv = 0 - do 1 iinst = 1 , noinst - nstaves = nsperi(iinst) - if (iinst .lt. 10) then - write(11,'(a)')sq//'setstaffs'//chax(48+iinst) - * //chax(48+nstaves) - else - write(11,'(a11,i2,a)')sq//'setstaffs{',iinst,'}' - * //chax(48+nstaves) - end if - iv = iv+1 - if (nstaves .eq. 1) then - fmtq = chax(48+numclef(clefq(iv))) - lfmtq = 1 - else - fmtq = '{'//chax(48+numclef(clefq(iv))) - lfmtq = 2 - do 2 k = 2 , nstaves - iv = iv+1 - fmtq = fmtq(1:lfmtq)//chax(48+numclef(clefq(iv))) - lfmtq = lfmtq+1 -2 continue - fmtq = fmtq(1:lfmtq)//'}' - lfmtq = lfmtq+1 - end if - if (iinst .lt. 10) then - write(11,'(a)')sq//'setclef'//chax(48+iinst)//fmtq(1:lfmtq) - else - write(11,'(a9,i2,a)')sq//'setclef{',iinst,'}'//fmtq(1:lfmtq) - end if - do 3 lname = 79 , 2 , -1 - if (inameq(iinst)(lname:lname) .ne. ' ') go to 4 -3 continue -4 continue - lnam(iinst) = lname - if (iinst .lt. 10) then - write(11,'(a8,i1,a)')sq//'setname',iinst, - * '{'//inameq(iinst)(1:lname)//'}' - else - write(11,'(a9,i2,a)')sq//'setname{',iinst, - * '}{'//inameq(iinst)(1:lname)//'}' - end if -1 continue - write(11,'(a18,i2,a2)')sq//'generalsignature{',isig,'}%' - if (EarlyTransOn) - * call Writesetsign(nInstTrans,iInstTrans,iTransKey,EarlyTransOn) - call wgmeter(mtrnmp,mtrdnp) - ipi = nint(fracindent*widthpt) - if (ipi .lt. 10) then - write(11,'(a11,i1,a2)')sq//'parindent ',ipi,'pt' - else if (ipi .lt. 100) then - write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt' - else - write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt' - end if - write(11,'(a)')sq//'elemskip1pt'//sq//'afterruleskip' - * //fbarq//'pt'//sq//'beforeruleskip0pt'//sq//'relax' - if (.not.vshrink) then - if (xinstf1 .lt. 9.95) then - fmtq = '(a,f3.1,a)' - else - fmtq = '(a,f4.1,a)' - end if - write(11,fmtq)sq//'stafftopmarg0pt'//sq//'staffbotmarg0pt' - * //sq//'interstaff{',xinstf1,'}'//sq//'relax' - else - write(11,'(a)')sq//'stafftopmarg0pt'// - * sq//'staffbotmarg5'//sq//'Interligne'//sq// - * 'interstaff{10}'//sq//'relax' - end if - if (nv.eq.1) write(11,'(a)')sq//'nostartrule' - write(11,'(a)')sq//'readmod{'//basenameq(1:lbase)//'}' - if (cstuplet) then - write(11,'(a)')sq//'input tuplet' - * //sq//'def'//sq//'xnumt#1#2#3{'//sq//'zcharnote{#2}{~}' - * //sq//'def'//sq//'tuplettxt{'//sq//'smalltype'//sq//'it{#3}' - * //sq//'/'//sq//'/}}%' - write(11,'(a)')sq//'let'//sq//'ovbkt'//sq//'uptuplet' - * //sq//'let'//sq//'unbkt'//sq//'downtuplet%' - end if - write(11,'(a)')sq//'startmuflex'//sq//'startpiece'//sq// - * 'addspace'//sq//'afterruleskip%' - return - end - character*1 function udfq(nolev,ncm) -c -c Slur directions -c - common /combc/ bcspec - logical bcspec - ntest = nolev-ncm - if (ntest.lt.0 .or. - * (ntest.eq.0 .and. bcspec .and. ncm.eq.23) ) then - udfq = 'd' - else - udfq = 'u' - end if - return - end - character*1 function udqq(nole,ncm,isl,nvmx,ivx,nv) -c -c Stem direction for single notes -c - character*1 ulfq - character*1 udqqq - logical btest - if (btest(isl,30)) then -c -c Absolute override -c - if (btest(isl,17)) then - udqqq = 'u' - else - udqqq = 'l' - end if - else if (nvmx .eq. 1) then -c -c Single voice per staff, default -c - udqqq = ulfq(1.*nole,ncm) - else -c -c Multi-voice per staff, 1st is lower, 2nd upper -c - if (ivx .le. nv) then - udqqq = 'l' - else - udqqq = 'u' - end if - end if - udqq = udqqq - return - end - character*1 function ulfq(xnolev,ncm) -c -c Stem directions -c - common /combc/ bcspec - logical bcspec - test = xnolev-ncm - if (test.lt.-.001 .or. - * (test.lt..001.and.bcspec.and.ncm.eq.23) ) then - ulfq = 'u' - else - ulfq = 'l' - end if - return - end - function upcaseq(chq) - character*1 chq,upcaseq,chax - if (ichar(chq).ge.61.and.ichar(chq).lt.122) then - upcaseq = chax(ichar(chq)-32) - else - upcaseq = chq - print*,'Warning, upcaseq was called with improper argument: ' - * //chq - stop - end if - return - end - subroutine wgmeter(mtrnmp,mtrdnp) -c -c Writes meter stuff to file 11, so only called if islast=.true. -c - character*1 sq,chax - if (mtrdnp .eq. 0) return - sq=chax(92) - if (mtrnmp.gt.0 .and. mtrnmp.le.9) then - if (mtrdnp .lt. 10) then - write(11,'(a25,i1,a2,i1,a3)') - * sq//'generalmeter{'//sq//'meterfrac{', - * mtrnmp,'}{',mtrdnp,'}}%' - else - write(11,'(a25,i1,a2,i2,a3)') - * sq//'generalmeter{'//sq//'meterfrac{', - * mtrnmp,'}{',mtrdnp,'}}%' - end if - else if (mtrnmp .ge. 10) then - if (mtrdnp .lt. 10) then - write(11,'(a25,i2,a2,i1,a3)') - * sq//'generalmeter{'//sq//'meterfrac{', - * mtrnmp,'}{',mtrdnp,'}}%' - else - write(11,'(a25,i2,a2,i2,a3)') - * sq//'generalmeter{'//sq//'meterfrac{', - * mtrnmp,'}{',mtrdnp,'}}%' - end if - else if (mtrnmp .lt. 0) then - write(11,'(a26,i1,a2,i1,a3)') - * sq//'generalmeter{'//sq//'meterfracS{', - * -mtrnmp,'}{',mtrdnp,'}}%' - else if (mtrdnp .le. 4) then - write(11,'(a21,i1,a2)') - * sq//'generalmeter{'//sq//'meterN',mtrdnp,'}%' - else if (mtrdnp .eq. 5) then - write(11,'(a)')sq//'generalmeter'//sq//'allabreve%' - else if (mtrdnp .eq. 6) then - write(11,'(a)')sq//'generalmeter'//sq//'meterC%' - else if (mtrdnp .eq. 7) then - write(11,'(a)')sq//'generalmeter'//sq//'meterIIIS%' - end if - return - end - subroutine writemidi(jobname,ljob) - parameter(nm=24,mv=24576) - common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, - * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), - * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), - * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), - * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, - * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), - * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), - * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), - * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) - character*1 ulq,sepsymq,sq - logical beamon,firstgulp,figbass,figchk,isfig - character*1 byteq(4),char,chax - character*10 tempoq,instq - character*44 jobname - integer*2 mmidi - logical restpend,relacc,notmain,twoline,ismidi,crdacc - common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, - * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), - * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), - * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, - * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), - * debugmidi - logical debugmidi - common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) - * ,miditran(nm),midtc(0:nm) - common /comevent/ miditime,lasttime - logical mmacrec,gottempo - common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, - * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), - * mmacrec,gottempo - character*79 inameq - common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, - * isig,lastisig,fracindent,widthpt,height,idsig, - * lnam(nm),inameq(nm) - logical rename - common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) -c -c Used to be icmm(0:nm); did midi fail when nv>16? -c - integer*2 iinsiv(nm),icmm(0:15) - character*5 versionc - common /comver/ versionc -c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ - data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/ -c Can't remember why these were not consecutive. -c data icmm /0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ -c -c Write Header -c - write(51,'(a,$)')'MThd'//char(0)//char(0)//char(0)//char(6) - * //char(0)//char(1)//char(0)//char(numchan+1)//char(0)//char(240) - if (debugmidi) - * write(52,'(a6,10Z4)')'"MThd"',0,0,0,6, - * 0,1,0,numchan+1,0,240 -c -c Write the "conductor" track, for keys, meter, and tempos -c Get the number of bytes in the conductor event stream -c - ndata = 1+imidi(numchan)-msecstrt(numchan,nmidsec) - do 15 isec = 1 , nmidsec-1 - ndata = ndata+1+msecend(numchan,isec)-msecstrt(numchan,isec) -15 continue -c ib1 = (4+ljob+26+ndata+4)/256 -c ib0 = 4+ljob+26+ndata+4-256*ib1 - ib1 = (4+ljob+27+ndata+4)/256 - ib0 = 4+ljob+27+ndata+4-256*ib1 - write(51,'(a,$)')'MTrk'//char(0)//char(0)//char(ib1)//char(ib0) -c -c Text header -c -c * //char(0)//char(255)//char(1)//char(ljob+26) - * //char(0)//char(255)//char(1)//char(ljob+27) - if (debugmidi) - * write(52,'(a6,8z4)')'"MTrk"',0,0,ib1,ib0, - * 0,255,1,ljob+27 - write(51,'(a,$)')jobname(1:ljob) - if (debugmidi) write(52,'(a)')'"'//jobname(1:ljob)//'"' -c -c (separate writes are needed to defeat compiler BUG!!!) -c -c write(51,'(a,$)')'.mid, produced by PMX 2.30' - write(51,'(a,$)')'.mid, produced by PMX '//versionc - if (debugmidi) write(52,'(a)') - * '".mid, produced by PMX '//versionc//'"' -c -c Conductor event data: Loop over sections. -c - do 16 isec = 1 , nmidsec - if (isec .lt. nmidsec) then - mend = msecend(numchan,isec) - else - mend = imidi(numchan) - end if - do 17 i = msecstrt(numchan,isec) , mend - write(51,'(a,$)')char(mmidi(numchan,i)) - if (debugmidi) write(52,'(z4)')mmidi(numchan,i) -17 continue -16 continue -c -c And close out the time sig / tempo track. -c - write(51,'(a,$)')char(0)//char(255)//char(2*16+15)//char(0) - if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0 -c -c Loop over track for each voice: The following sets up iv. -c - iv = nv - if (twoline(nv)) then - kv = 2 - else - kv = 1 - end if -c -c Count up staves(iv,nv) vs instruments. Store instr# for iv in iinsiv(iv) -c - nstaves = 0 - ivt = 0 - do 12 iinst = 1 , nm - nstaves = nstaves+nsperi(iinst) - do 13 ivtt = 1 , nsperi(iinst) - ivt = ivt+1 - iinsiv(ivt) = iinst -13 continue - if (nstaves .eq. nv) go to 14 -12 continue - print*,'Screwup!' - call stop1() -14 continue -c - do 5 icm = 0 , numchan-1 -c -c Get the number of bytes in the data stream -c - ndata = 1+imidi(icm)-msecstrt(icm,nmidsec) - do 11 isec = 1 , nmidsec-1 - ndata = ndata+1+msecend(icm,isec)-msecstrt(icm,isec) -11 continue -c -cc Add 3 (for instrum) plus 4 (for closing) to byte count, -c Add 3 for instrum, 4 for bal, plus 4 (for closing) to byte count, -c -c ndata = ndata+7 - ndata = ndata+11 -c -c Add 4+lnam(iinsiv(iv)) if lnam>0 , -c - if (lnam(iinsiv(iv)).gt.0) ndata = ndata+4+lnam(iinsiv(iv)) -c -c Separate total byte counts into 4 bytes -c - do 2 ibyte = 1 , 4 - if (ndata .gt. 0) then - byteq(ibyte) = char(mod(ndata,256)) - ndata = ishft(ndata,-8) - else - byteq(ibyte) = char(0) - end if -2 continue -c -c Now write front stuff for this track -c - write(51,'(a,$)')'MTrk'//byteq(4)//byteq(3)//byteq(2)//byteq(1) - * //char(0)//char(12*16+icmm(icm))//char(midinst(iv)) - * //char(0)//char(11*16+icmm(icm))//char(10)//char(midbc(icm)) - if (debugmidi) write(52,'(a4,z2,a7,11z4)')'icm=',icm, - * ' "MTrk"',ichar(byteq(4)),ichar(byteq(3)),ichar(byteq(2)), - * ichar(byteq(1)),0,12*16+icmm(icm),midinst(iv), - * 0,11*16+icmm(icm),10,midbc(icm) - if (lnam(iinsiv(iv)) .gt. 0) then -c -c Add instrument name as sequence name -c - write(51,'(a,$)')char(0)//char(255)//char(3) - * //char(lnam(iinsiv(iv))) - if (debugmidi) write(52,'(4z4)')0,255,3,lnam(iinsiv(iv)) - write(51,'(a,$)') - * inameq(iinsiv(iv))(1:lnam(iinsiv(iv))) - if (debugmidi) write(52,'(a)') - * '"'//inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))//'"' - end if - write(tempoq,'(i2)')icm - write(instq,'(i3)')midinst(iv) - call printl('MIDI instrument '//tempoq(1:2)//' is '//instq(1:3)) -c -c Notes: Loop over sections. -c - do 9 isec = 1 , nmidsec - if (isec .lt. nmidsec) then - mend = msecend(icm,isec) - else - mend = imidi(icm) - end if - do 10 i = msecstrt(icm,isec) , mend - write(51,'(a,$)')char(mmidi(icm,i)) - if (debugmidi) write(52,'(z4)')mmidi(icm,i) -10 continue -9 continue -c -c Closing 4 bytes -c - write(51,'(a,$)')chax(0)//char(255)//char(2*16+15)//char(0) - if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0 - if (kv .eq. 2) then - kv = 1 - else if (iv .eq. 1) then - go to 5 - else - iv = iv-1 - if (twoline(iv)) kv=2 - end if -5 continue - write(*,'(1x,a12,(10i6))')'Bytes used:',(imidi(icm),icm=0,numchan) - write(15,'(1x,a12,(10i6))') - * 'Bytes used:',(imidi(icm),icm=0,numchan) - close(51) - if (debugmidi) close(52) - return - end - subroutine Writesetsign(nInstTrans,iInstTrans,iTransKey,flag) - parameter(nm=24) - integer*4 iInstTrans(nm),iTransKey(nm) - character*79 notexq - character*1 chax - logical flag -c -c Assumes notexq is blank -c - do 1 i = 1 , nInstTrans - notexq = chax(92)//'setsign' - lnote = 8 - if (iInstTrans(i) .lt. 10) then - notexq = notexq(1:lnote)//chax(48+iInstTrans(i)) - lnote = lnote+1 - else - write(notexq(lnote+1:lnote+4),'(a1,i2,a1)') - * '{',iInstTrans(i),'}' - lnote = lnote+4 - end if - if (iTransKey(i) .lt. 0) then - write(notexq(lnote+1:lnote+4),'(a1,i2,a1)') - * '{',iTransKey(i),'}' - lnote = lnote+4 - else - notexq = notexq(1:lnote)//chax(48+iTransKey(i)) - lnote = lnote+1 - end if - write(11,'(a)')notexq(1:lnote)//'%' -1 continue - flag = .false. - return - end - subroutine writflot(x,notexq,lenline) - character*(*) notexq - if (x .lt. 0.95) then - write(notexq(lenline+1:lenline+2),'(f2.1)')x - lenline = lenline+2 - else if (x .lt. 9.95) then - write(notexq(lenline+1:lenline+3),'(f3.1)')x - lenline = lenline+3 - else - write(notexq(lenline+1:lenline+4),'(f4.1)')x - lenline = lenline+4 - end if - return - end - subroutine wsclef(iv,ninow,clefq,nclef) -c -c Writes \setclef for instrument containing voice iv -c - parameter (nm=24) - common /comlast/ islast,usevshrink - logical islast,usevshrink - common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) - logical rename - character*1 clefq(nm),chax - character*20 temq - if (nclef .lt. 7) then - clefq(iv) = chax(48+nclef) - else - clefq(iv)='9' - end if - if (.not.islast) return - iv1 = 1 - do 1 iinst = 1 , ninow - if (iv .lt. iv1+nspern(iinst)) go to 2 - iv1 = iv1+nspern(iinst) -1 continue - print* - print*,'Should not be here in wsclef!' - call stop1() -2 continue - iv2 = iv1+nspern(iinst)-1 - if (iinst .lt. 10) then - temq = chax(92)//'setclef'//chax(48+iinst) - ltem = 9 - else - write(temq,'(a9,i2,a1)') chax(92)//'setclef{',iinst,'}' - ltem = 12 - end if - if (iv1 .eq. iv2) then - write(11,'(a)')temq(1:ltem)//clefq(iv)//'%' - else - temq = temq(1:ltem)//'{' - ltem = ltem+1 - do 3 iiv = iv1 , iv2 - temq = temq(1:ltem)//chax(48+numclef(clefq(iiv))) - ltem = ltem+1 -3 continue - write(11,'(a)')temq(1:ltem)//'}%' - end if - return - end diff --git a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.f b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.f deleted file mode 100644 index c784301d046..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.f +++ /dev/null @@ -1,1619 +0,0 @@ -cccccccccccccccccccccccccc -cc -cc scor2prt 7/24/11 for PMX 2.615 -cccccccccccccccccccccccccc -c This program, developed by Don Simons (dsimons@roadrunner.com), is -c part of the PMX distribution, PMX is a preprocessor for MusiXTeX. In concert -c with MusiXTeX and TeX, the purpose of PMX is to allow the user to create -c high-quality typeset musical scores by including a sequence of PMX commands -c in an ASCII input file. Scor2prt is an auxiliary program that creates PMX -c input files for individual parts from the PMX input file for the score. -c -c This program is free software: you can redistribute it and/or modify -c it under the terms of the GNU General Public License as published by -c the Free Software Foundation, either version 3 of the License, or -c (at your option) any later version. -c -c This program is distributed in the hope that it will be useful, -c but WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with this program. If not, see <http://www.gnu.org/licenses/>. -c -c -c 7/18/11 -c Start to fix up for AS..., also Ki was done a little earlier. -c 7/5/10 -c Modify Manual to explain extended hex numbering for part-specific comments -c 5/16/10 -c Extend part-specific comments for up to 24 parts (subroutine chkcom) -c Allow files 11-34 for parts -c Change file 30 to 40 -c 6/1/08 es2p -c noimax = 24 -c -c To do -c Override fracindent, musicsize? -c Deal with midbar R? -c 2/29/04 -c Check for special character being in quoted string. -c 10/20/02 PMX 2.407 -c Interpret AN[n]"[used-defined-part-file-name]" -c 1/21/02 -c Deals with rm in multiple parts. -c s2p15 -c Get right non-tex index even if there's "\" inside D"..." -c s2p14 -c 10/29/00 fix transfer to parts of negative mtrdnp -c 4/29/00 screen for "%%" followed by "T" -c Restore change from "Version 2.1a, 21 Dec" -c s2p13 -c Allow whole-bar double-whole rests. -c Bypass MIDI commands "I..." achar(10)="I" -c s2p12 -c Let %ablabla ... %cblabla represent pmx input for parts 10-12. But %?blabla -c only taken as such if ? represents a hex digit .le. noinst, otherwise it's -c a simple comment. This lessens incompatibility. -c In subroutine mbrest, properly open parts 10-12 if needed -c s2p11 -c Ignore leading blanks -c Fix undefined linelength in mbrest at very end of comments. -c s2p10 -c Fix non-transfer of P..c" " -c Allow "%%" and "%"n anywhere -c Version 1.43 -c Fix bug with P in TeX string. -c Ignore shifted whole-bar rests when consolidating whole-bar rests -c Copy type 4 TeX into all parts. -c Deal with XB and XP. -c Permit transfer of blank line into parts -c Change staves/inst in 'M' command. -c Arbitrary staves/inst. -c Recognize m1/2/3/4 syntax. -c Enable comment and one-voice syntax in instrument names -c -c Changes since 1.1 -c Deal with saved macros. -c Revise setup readin, to admit comments. -c Do not copy 'X' into parts -c -cccccccccccccccccccccccccccccccccccccccccccccccc - parameter (noimax=24) - common /all/ noinow,iorig(noimax),noinst,insetup,replacing, - * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow - integer*4 ludpfn(noimax) - character*1 sq,achar(10) - character*2 termsym - character*27 jobname,infileq - character*128 instrum(noimax),udpfnq(noimax) - character*128 line,holdln,templine - logical termrpt,isachar,frstln,oneof2,botv,clefpend,fexist, - * insetup,replacing,gotname,yesodd - data achar /'P','m','V','R','A','h','w','K','M','I'/ - clefpend = .false. - insetup = .true. - replacing = .false. - frstln = .true. - lenhold = 0 - sq = char(92) - print*,'This is scor2prt for PMX 2.615, 24 July 2011' - numargs = iargc() - if (numargs .eq. 0) then - print*,'You could have entered a jobname on the command line,' - print*,' but you may enter one now:' - read(*,'(a)')jobname - numargs = 1 - else -c call getarg(1,jobname,idum) ! May need to replace this w/ next line - call getarg(1,jobname) - end if - ljob = lenstr(jobname,27) - if (ljob .eq. 0) then - print*,'No was jobname entered. Restart and try again.' - stop - end if -c -c Strip ".pmx" if necessary -c - ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX')) - if (ndxpmx .gt. 0) then - jobname = jobname(1:ndxpmx-1) - ljob = ljob-4 - end if -c -c Check for existence of input file -c - infileq = jobname(1:ljob)//'.pmx' - inquire(file=infileq,EXIST=fexist) - if (.not.fexist) then - print*,'Cannot find file '//infileq - stop - end if - open(10,file=jobname(1:ljob)//'.pmx') -c -c Open all instrument files now for allparts stuff. Later disgard those >nv -c - do 19 iv = 1 , noimax - iorig(iv) = iv - open(10+iv,status='SCRATCH') - ludpfn(iv) = 0 -19 continue - read(10,'(a)')line - call chkcom(line) - if (line(1:3) .eq. '---') then - call allparts(line,128) -31 read(10,'(a)')line - if (line(1:3) .ne. '---') then - call allparts(line,128) - go to 31 - end if - call allparts(line,128) - read(10,'(a)')line - call chkcom(line) - end if - iccount = 0 - nv = readin(line,iccount,1)+.1 - noinst = readin(line,iccount,2)+.1 - if (noinst .gt. 0) then - nvi(1) = nv-noinst+1 - else - noinst = 1-noinst - do 21 iinst = 1 , noinst - nvi(iinst) = readin(line,iccount,-1)+.1 -21 continue - end if - noinow = noinst - insnow = 1 -c -c ivlast is last iv in current inst. instnum(iv) is iinst for current voice. -c - ivlast = nvi(1) - do 22 iv = 1 , nv - instnum(iv) = insnow - if (iv .eq. ivlast) then - if (iv .lt. nv) botv(iv+1) = .true. -c -c The previous stmt will set botv true only for bot voice of iinst>1. It is -c used when writing termrpts, but the one in voice one is handled differently, -c so botv(1) is left .false. -c - if (insnow .lt. noinst) then - insnow = insnow+1 - ivlast = ivlast+nvi(insnow) - end if - end if -22 continue - mtrnuml = readin(line,iccount,0)+.1 - mtrdenl = readin(line,iccount,0)+.1 - mtrnmp = readin(line,iccount,0)+.1 - mtrdnp = readin(line,iccount,0)+.1 - xmtrnum0 = readin(line,iccount,0) - isig = readin(line,iccount,0)+.1 - npages = readin(line,iccount,3)+.1 - nsyst = readin(line,iccount,0)+.1 - musicsize = readin(line,iccount,4)+.1 - fracindent = readin(line,iccount,5) - if (npages .eq. 0) then - print*, - *'You entered npages=0, which means nsyst is not the total number' - print*, - *'of systems. Scor2prt has to know the total number of systems.' - print*, - *'Please set npages and nsyst to their real values.' - stop - end if -c -c Must leave insetup=.true. else could bypass ALL instrument names. -c - read(10,'(a)')line - call chkcom(line) - backspace(10) -c -c Normally this puts pointer at start of line with 1st inst name -c Check if prior line was "%%" -c - backspace(10) - read(10,'(a)')line - if (line(1:2) .eq. '%%') backspace(10) - do 14 iv = 1 , noinst - gotname = .false. -16 read(10,'(a)') instrum(iv) - if (instrum(iv)(1:2) .eq. '%%') then - read(10,'(a)')line - go to 16 - else if (instrum(iv)(1:1) .eq. '%') then - ivq = ichar(instrum(iv)(2:2))-48 - if (ivq.ne.iv) then -c -c It's really a comment. Copy to parts, then get another trial name. -c - call allparts(instrum(iv),128) - go to 16 - else - line = instrum(iv)(3:) - instrum(iv) = line - gotname = .true. - end if - else - gotname = .true. - end if -cc -cc The following checks for macro that write original C-clef as part of -cc instrument name. See pmx.tex -cc -c if (index(instrum(iv),'namewpc') .eq. 0) then -c write(10+iv,'(a)')' ' -c else -c inm1 = index(instrum(iv),'{')+1 -c inm2 = index(instrum(iv),'}')-1 -c read(instrum(iv)(inm2+2:inm2+8),'(i1,4x,2i1)')ilev,iy1,iy2 -c write(10+iv,'(a)')sq//'namewpc{}'//char(ilev+48)//'{20}'// -c * char(iy1+49)//char(iy2+49) -c instrum(iv) = instrum(iv)(inm1:inm2) -c end if - if (.not.gotname) then - print*,'You must provide a replacement instrument name' - stop - end if - write(10+iv,'(a)')' ' -14 continue - replacing = .false. - nvnow = nv -c -c Clef string: Note insetup is still T, so "%%" will be treated specially -c - read(10,'(a)')line - call chkcom(line) - if (replacing) then -c -c If here, we have next line after "%%", containing score's clef string -c Assume all clefs are handled with instrument comments. -c - read(10,'(a)')line - call chkcom(line) - backspace(10) - else -c -c If here, line has the clef string in it. Handle the old way -c - kvstart = 1 - kvend = nvi(1) - do 2 inst = 1 , noinst - write(10+inst,'(a'//char(48+nvi(inst))//')') - * line(kvstart:kvend) - if (inst .lt. noinst) then - kvstart = kvend+1 - kvend = kvstart+nvi(inst+1)-1 - end if -2 continue - end if - replacing = .false. - insetup = .false. -c -c *****NOTE*****This comment applies to stuff done earlier! -c Before starting the big loop, copy initial instnum and staffnum stuff -c into working values. Latter may change if noinst changes. Also make -c list of current inst nums relative to original ones. In addition to those -c below, must redo instnum(iv) and botv(iv) when we change noinst. -c -c Path string: ASSUME THIS WILL NEVER BE ALTERED IN PARTS! -c -18 read(10,'(a)') line - if (line(1:1) .eq. '%') then - call allparts(line,128) - go to 18 - end if - call allparts(line,128) -c -c Write instrument names. Will be blank if later part of a score. -c - if (instrum(1)(1:1) .ne. ' ') then - do 3 iv = 1 , noinst - len = lenstr(instrum(iv),79) - write(10+iv,'(a2/a)')'Ti',instrum(iv)(1:len) -3 continue - end if -c -c The big loop. Except for '%%', put all comment lines in all parts. -c Unless preceeded by '%%', put all type 2 or 3 TeX Strings in all parts -c If a line starts with %!, put the rest of it in each part. -c If a line starts with %[n], put the rest of it in part [n]. -c Check for Tt, Tc, Voltas, Repeats, headers, lower texts, meter changes. -c Assume they only come at top of block, except terminal repeat needs -c special handling. -c Check for "P"; ignore in parts. -c Check for consecutive full-bar rests; if found, replace with rm[nn] -c - iv = 1 - iinst = 1 - termrpt = .false. -4 read(10,'(a)',end=999)line - lenline = lenstr(line,128) - if (lenline .eq. 0) go to 4 - call zapbl(line,128) - call chkcom(line) - lenline = lenstr(line,128) - if (lenline .eq. 0) go to 4 - if (line(1:1) .eq. 'T') then - call allparts(line,128) - read(10,'(a)')line - call allparts(line,128) - go to 4 - else if (line(1:2) .eq. sq//sq) then - call allparts(line,128) - go to 4 - else if (index('hl',line(1:1)).gt.0 .and. - * index(' +-',line(2:2)) .gt. 0) then - call allparts(line,128) - read(10,'(a)')line - call allparts(line,128) - go to 4 - else if (iv .eq. 1) then - do 5 ia = 1 , 10 -24 continue - idxa = ntindex(line,achar(ia)) - isachar = idxa .gt. 0 - if (idxa.gt.1) isachar = line(idxa-1:idxa-1).eq.' ' -c -c 1 2 3 4 5 6 7 8 9 10 -c data achar /'P','m','V','R','A','h','w','K','M','I'/ -c - if (ia .eq. 9) isachar = - * isachar .and. line(idxa+1:idxa+1).eq.'S' - if (isachar) then -c -c Check whether character is inside a quoted string by counting -c how many quotes precede it in the line -c - - call OddQuotesBefore(line,idxa,yesodd) - if (yesodd) isachar=.false. - end if - if (isachar) then -c -c Find next blank -c - do 6 ib = idxa+1 , 128 - if (line(ib:ib) .eq. ' ') go to 7 -6 continue - print*,'Problem with "V,R,m,P,A,h,MS, or w"' - print*, - * 'Send files to Dr. Don at dsimons at roadrunner dot com' - stop 1 -7 continue -c -c Next blank is at position ib. Later, if ia=1, must check for Pc" " ; -c i.e., look for '"' between P and blank -c - if (ia .eq. 4) then -c -c Check for terminal repeat. Note if there's a term rpt, there can't be any -c others. Also, must process repeats LAST, after m's and 'V's -c - do 8 ic = ib+1 , 128 -c -c If any subsequent character on this line is neither blank nor "/", get out -c - if (index(' /',line(ic:ic)) .eq. 0) go to 9 - if (line(ic:ic) .eq. '/') then - termrpt = .true. - termsym = line(ib-2:ib-1) -c -c Process the line as if there were no "R" -c - go to 10 - end if -8 continue -c -c +++ 060812 -c If here, all chars after "R" symbol are blanks, so process the line normally, -c but only IF next line is not the M-Tx line " /" -c - read(10,'(a)')templine - if (templine(1:2) .ne. ' /') then - backspace(10) ! and flow out - else -c -c We have the M-Tx case where one line ends with R? and next is " /". Add / to the line, -c and proceed as above -c - line = line(1:ib)//'/' - lenline = lenline+2 - termrpt = .true. - termsym = line(ib-2:ib-1) - go to 10 - end if -c +++ 060812 -c - else if (ia .eq. 1) then - idxq = ntindex(line,'"') - if (idxq.gt.idxa .and. idxq.lt.ib) then -c -c Quote is between P and next blank. Find 2nd quote, starting at the blank. -c - idxq2 = ib-1+ntindex(line,'"') - if (idxq.eq.0 .or. line(idxq2+1:idxq2+1).ne.' ') then - print* - print*,'Error copying P with quotes, idxq2:',idxq2 - print*,line(1:60) - stop 1 - end if - ib = idxq2+1 - end if -c -c Do not transfer P into parts. -c - go to 12 - else if (ia .eq. 9) then -c -c Start Saving a macro. After leaving here, a symbol will be sent to all parts, -c If all on this line, set ib to end and exit normally. -c - ndxm = index(line(ib+1:128),'M') - if (ndxm.gt.0 .and. line(ib+ndxm-1:ib+ndxm-1).eq.' ') then -c -c Macro ends on this line -c - ib = ib+ndxm+1 - else -c -c Save leading part of current line -c - lenhold = idxa-1 - if (lenhold .gt. 0) holdln = line(1:lenhold) -c -c Transfer rest of line -c - call allparts(line(idxa:128),129-idxa) -c -c Read next line -c -20 read(10,'(a)')line -c -c Check for comment, transfer and loop if so -c -c if (line(1:1) .eq.'%') then -23 if (line(1:1) .eq.'%') then -c call allparts(line,128) -c go to 20 - call chkcom(line) - go to 23 - end if -c -c Look for terminal ' M' -c - if (line(1:1) .eq. 'M') then - ndxm = 1 - else - ndxm = index(line,' M') - if (ndxm .gt. 0) ndxm = ndxm+1 - end if - if (ndxm .gt. 0) then -c -c Set parameters, exit normally (but later check for leading part of 1st line -c - idxa = 1 - ib = ndxm+1 - else -c -c No "M", transfer entire line, loop -c - call allparts(line,128) - go to 20 - end if - end if - else if (ia .eq. 10) then -c -c Do not transfer MIDI command into parts -c - go to 12 - else if (ia .eq. 5) then -c -c First check for "AS", but S may come after other "A" options -c - idxS = index(line(idxa+1:ib),'S') - if (idxS .gt. 0) then -c -c Get rid of the string. First check if that's all there is in A. -c - if (ib-idxa .eq. nv+2) go to 12 - line = line(1:idxa+idxS-1)//line(idxa+idxS+nv+1:ib) - end if -c -c Check for user-defined part file name. Must start in column 1 and have -c AN[n]"userfilename". -c idxa is position of "A" -c ib is position of the next blank after "A" -c Don't allow any blanks in user -c - if (line(idxa+1:idxa+1) .ne. 'N') go to 9 ! bail out - if (idxa .ne. 1) then - print* - print*, - * 'You entered "AN..." somewhere beyond first column; stopping.' - stop 1 - end if -c -c pmxa already checked for valid one- or 2-digit number, so get it -c - if (line(4:4) .eq. '"') then -c -c Single digit instrument number -c - read(line(3:3),'(i1)')iudpfn - idxstartname = 5 - else - read(line(3:4),'(i2)')iudpfn - idxstartname = 6 - end if - ludpfn(iudpfn) = index(line(idxstartname:128),'"')-1 - if (ludpfn(iudpfn) .lt. 0) then - print* - print*,'User-defined part file name must be in quotes' - stop 1 - end if - idxendname = idxstartname+ludpfn(iudpfn)-1 - udpfnq(iudpfn) = line(idxstartname:idxendname) -c -c Get a new line! -c - go to 4 - else if (ia .eq. 8) then -c -c Key change/transposition. -c If not instrument specific, copy to all parts -c - if (line(idxa+1:idxa+1).ne.'i') go to 9 -c -c Instrument-wise key/transposition(s): Ki[nn][+/-][dd}[+/-][dd]... -c - ibb = idxa+2 ! Starts on digit after 'i' -40 continue - read(line(ibb:ibb),'(i1)')iiinst ! 1st digit of iinst - itemp = (index('01234567890',line(ibb+1:ibb+1))) - if (itemp.gt.0) then - ibb = ibb+1 - iiinst = 10*iiinst+itemp-1 - end if - ibb = ibb+1 ! now at first +/-. Need end of 2nd number - itemp = index(line(ibb+1:ib),'i') ! Rel pos'n of next 'i' or 0 - if (itemp .gt. 0) then - iend = ibb+itemp-1 - else - iend = ib-1 - end if - write(10+iorig(iiinst),'(a)')'Ki1'//line(ibb:iend) - if (itemp .gt. 0) then - ibb = iend+2 - go to 40 - end if - go to 12 ! Remove K command from string, go to next ia - end if -9 continue - call allparts(line(idxa:ib-1),ib-idxa) -12 continue -c -c Remove the string from line -c - if (idxa .eq. 1) then - line = line(ib:128) - else - line = line(1:idxa-1)//line(ib:128) - end if - lenline = lenstr(line,128) -c -c Loop if only blanks are left -c - if (lenline .eq. 0) go to 4 -c -c Must check for multiple "I" commands, so go to just after start of ia loop -c - if (ia .eq. 10) go to 24 -c -c Tack on front part from 1st line of saved macro -c - if (lenhold .gt. 0) then - line = holdln(1:lenhold)//' '//line(1:lenline) - lenhold = 0 - end if - end if -5 continue - end if -c -c Now a special loop to deal with 'X'. If it was %[n]X..., will have been -c copied into part [n] already. If no "B" or "P", remove. If "P", just -c remove the "P" so pmxa/b will process. If "B". do nothing. -c -10 continue - nchk = 1 -13 ntinx = nchk-1+ntindex(line(nchk:),'X') - if (ntinx .gt. nchk-1) then -c -c There is a non-TeX 'X' at ntinx. Loop if neither 1st nor after a blank. -c - if (ntinx.gt.1) then - if (line(ntinx-1:ntinx-1).ne.' ') then -c -c The X is not 1st char of PMX command. Advance starting point, loop. -c - nchk = ntinx+1 - go to 13 - end if - end if -c -c We now know the X at ntinx starts a PMX command. Find next blank -c - ib = ntinx+index(line(ntinx+1:),' ') -c -c There must be a blank to right of "X", so ib>ntinx -c -c locp = nchk-1+index(line(nchk:ib),'P') - locp = ntinx+index(line(ntinx+1:ib),'P') -c -c Did not need to use ntindex because we already know bounds of PMX command. -c -c if (locp .gt. nchk-1) then - if (locp .gt. ntinx) then -c -c Strip out the 'P' -c - templine = line(1:locp-1) - line = templine(1:locp-1)//line(locp+1:lenline) - lenline = lenline-1 - ib = ib-1 - end if - if (index(line(ntinx:ib),':').gt.0 .or. - * index(line(ntinx:ib),'S').gt.0 .or. - * index(line(ntinx:ib),'B').gt.0 .or. locp.gt.ntinx) then -c -c The X command is a shift, "Both", or "Part". Do not remove. -c - nchk = ib+1 - go to 13 - end if -c -c Remove the X command. -c - if (ntinx .eq. 1) then - if (ib .lt. lenline) then - line = line(ib+1:lenline) - else -c -c line contains ONLY the "X" command, so get a new line -c - go to 4 - end if - else - templine = line(1:ntinx-1) - if (ib .lt. lenline) then - line = templine(1:ntinx-1)//line(ib+1:lenline) - else - line = templine(1:ntinx-1) - end if - end if -c -c Recompute lenline -c - lenline = lenstr(line,128) -c -c Resume checking after location of removed command. -c - nchk = ntinx - go to 13 - end if -c -c End of loop for X-checks -c - oneof2 = ntindex(line,'//') .gt. 0 - if (termrpt .and. botv(iv) .and. frstln .and. - * line(lenline:lenline).eq.'/') then -c -c Must add a terminal repeat before the slash -c - if (oneof2) lenline = lenline-1 - if (lenline.gt.1) write(10+iorig(iinst),'(a)')line(1:lenline-1) - if (.not. oneof2) then - line = termsym//' /' - lenline = 4 - else - line = termsym//' //' - lenline = 5 - end if - end if - if (termrpt .and. frstln .and. line(lenline:lenline).eq.'/' .and. - * iv.eq.nvnow) termrpt = .false. - write(10+iorig(iinst),'(a)')line(1:lenline) - if (oneof2) then - frstln = .false. - else if (.not.frstln) then - frstln = .true. - end if -c if (ntindex(line,'/').gt.0 .and. index(line,'//').eq.0) then - if (ntindex(line,'/').gt.0 .and. ntindex(line,'//').eq.0) then - iv = 1+mod(iv,nvnow) - iinst = instnum(iv) - end if - go to 4 -999 continue - close(10) -c -c In the mbrest checks, must run through ALL noinst files (not just noinow) -c - do 11 iinst = 1 , noinst -ccc+++ -cc -cc Temporarily transfer entire scratch file to real file -cc -c rewind(10+iinst) -c open(40,file='s2pout'//char(48+iinst)//'.pmx') -c do 50 m = 1 , 10000 -c read(10+iinst,'(a)',end=51)line -c lenline = lenstr(line,128) -c if (lenline .ge. 1) then -c write(40,'(a)')line(1:lenline) -c else -c write(40,'(a)')' ' -c end if -c50 continue -c51 continue -c close(40) -ccc+++ - if (nvi(iinst) .eq. 1) then - call mbrests(iinst,jobname,ljob,ludpfn(iinst),udpfnq(iinst)) - else -c -c Send a signal with ljob to bypass most mbrest processing -c - call mbrests(iinst,jobname,-ljob,ludpfn(iinst),udpfnq(iinst)) - end if -11 continue - end - function lenstr(string,n) - character*(*) string - do 1 lenstr = n , 1 , -1 - if (string(lenstr:lenstr) .ne. ' ') return -1 continue - lenstr = 0 - return - end - subroutine allparts(string,n) - parameter (noimax=24) - character*(*) string - common /all/ noinow,iorig(noimax),noinst,insetup,replacing, - * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow - logical insetup,replacing,botv - len = lenstr(string,n) - if (len .eq. 0) then - len = 1 - string = ' ' - end if - do 1 iinst = 1 , noinow - write(10+iorig(iinst),'(a)')string(1:len) -1 continue - return - end - subroutine mbrests(iv,jobname,ljob,ludpfn,udpfnq) - character*128 line(50),line1,udpfnq - character*80 sym - character*12 jobname - character*3 wbrsym(2) - character*2 partq - character*1 sq - logical wbrest,alldone,rpfirst,newmtr,type4 - type4 = .false. - sq = char(92) - alldone = .false. - rewind(10+iv) -c open(20,file=jobname(1:abs(ljob))//char(48+iv)//'.pmx') - if (iv .lt. 10) then - partq(1:1) = char(48+iv) - lpart = 1 -c -c 5/16/10 Fix for >20 parts -c -c else -c partq = '1'//char(38+iv) -c lpart = 2 - else - lpart = 2 - if (iv .lt. 20) then - partq = '1'//char(38+iv) - else - partq = '2'//char(28+iv) - end if - end if -c if (ludpfn .eq. 0) then - open(40,file=jobname(1:abs(ljob))//partq(1:lpart)//'.pmx') -c else -c open(30,file=udpfnq(1:ludpfn)//'.pmx') -c end if - do 10 i = 1 , 10000 - read(10+iv,'(a)')line(1) - if (line(1)(1:1).eq.'%' .or. line(1)(1:3).eq.'---' - * .or. type4) then - len = lenstr(line(1),128) - if (len .gt. 0) then - write(40,'(a)')line(1)(1:len) - else - write(40,'(a)')' ' - end if - if (line(1)(1:3).eq.'---') type4 = .not.type4 - else - go to 11 - end if -10 continue - print*,'You should not be here in scor2prt. Call Dr. Don' - stop -11 continue -c -c Finished reading opening type4 TeX and comments. Next line to be read -c will contain the first of the input numbers -c - call dosetup(iv,line(1),mtrnum,mtrden) - do 1 i = 1 , 10000 -13 read(10+iv,'(a)',end=999)line(1) -7 len = lenstr(line(1),128) -c -c Pass-through if instrumnet has >1 voice. -c - if (ljob .lt. 0) go to 2 - if (index('TtTiTch+h-h l ',line(1)(1:2)) .gt. 0) then -c -c Traps titles, instruments, composers, headers, lower strings. Read 2 lines. -c - write(40,'(a)')line(1)(1:len) - read(10+iv,'(a)')line(1) - len = lenstr(line(1),128) - go to 2 - end if - if (i.eq.1 .or. (i.gt.5.and.line(1)(1:1).eq.'m')) then -c -c NOTE! The above test is truly bogus. -c - if (line(1)(1:1) .eq. '%') then - write(40,'(a)')line(1)(1:len) - go to 13 - end if - if (i .eq. 1) then -c read(line(1),'(10x,2i5)')mtrnum,mtrden - else -c -c Check for slashes (new meter change syntax) -c - idxs = index(line(1),'/') - idxb = index(line(1),' ') - newmtr = idxs.gt.0 .and. (idxb.eq.0 .or. idxs.lt.idxb) - if (.not.newmtr) then -c -c Old way, no slashes, uses 'o' for lonesome '1' -c - icden = 3 - if (line(1)(2:2) .eq. 'o') then - mtrnum = 1 - else - mtrnum = ichar(line(1)(2:2))-48 - if (mtrnum .eq. 1) then - icden = 4 - mtrnum = 10+ichar(line(1)(3:3))-48 - end if - end if - mtrden = ichar(line(1)(icden:icden))-48 - else -c -c New way with slashes: idxs is index of 1st slash! -c - read(line(1)(2:idxs-1),'(i'//char(48+idxs-2)//')')mtrnum - idxb = index(line(1)(idxs+1:),'/') - read(line(1)(idxs+1:idxs+idxb-1), - * '(i'//char(48+idxb-1)//')')mtrden - end if - end if - lenbeat = ifnodur(mtrden,'x') - lenmult = 1 - if (mtrden .eq. 2) then - lenbeat = 16 - lenmult = 2 - end if - lenbar = lenmult*mtrnum*lenbeat - call fwbrsym(lenbar,nwbrs,wbrsym,lwbrs) - end if - ip1 = 0 - line1 = line(1) - do 3 iw = 0 , nwbrs - if (iw .gt. 0) then - idx = ntindex(line1,wbrsym(iw)(1:lwbrs)) - if (idx .gt. 0) then -c -c Check for blank or shifted rest, discount it if it's there -c - if (line1(idx+lwbrs:idx+lwbrs).ne.' ') idx = 0 - end if - else - idx = ntindex(line1,'rp') -c -c Check for raised rest -c - if (idx.gt.0) then - if (line1(idx+2:idx+2).ne.' ') idx = 0 - end if - end if - if (idx .gt. 0) then - if (ip1 .eq. 0) then - ip1 = idx - else - ip1 = min(ip1,idx) - end if - end if -3 continue - if (i.lt.5 .or. line(1)(1:1).eq.'%' .or. line(1)(1:2).eq.sq//sq - * .or. ip1.eq.0) go to 2 -c -c Switch to multibar rest search mode!!! Start forward in line(1) -c - rpfirst = line1(ip1:ip1+1) .eq. 'rp' - iline = 1 - nmbr = 1 - if (rpfirst) then - lwbrsx = 2 - else - lwbrsx = lwbrs - end if - ipe = ip1+lwbrsx-1 -4 if (ipe .eq. len) then -c -c Need a new line -c - iline = iline+1 -6 read(10+iv,'(a)',end=998)line(iline) - len = lenstr(line(iline),128) - if (line(iline)(1:1).eq.'%' ) then - write(40,'(a)')'% Following comment has been moved forward' - write(40,'(a)')line(iline)(1:len) - go to 6 - end if - ipe = 0 - go to 4 -998 continue -c -c No more input left -c - print*,'All done!' - alldone = .true. - ipe = 0 - iline = iline-1 - len = lenstr(line(iline),128) - go to 4 - else - if (alldone) then - sym(1:1) = ' ' - else -c -c ipe<len here, so it's ok to get a symbol -c - call nextsym(line(iline),len,ipe,ipenew,sym,lsym) - end if -c -c Check for end of block or bar line symbol -c - if (index('/|',sym(1:1)) .gt. 0) then - ipe = ipenew - go to 4 - else - wbrest = .false. - if (alldone) go to 12 - do 5 iw = 1 , nwbrs - wbrest = wbrest .or. sym(1:lsym).eq.wbrsym(iw)(1:lwbrs) -5 continue - wbrest = wbrest .or. (sym(1:lsym).eq.'r'.and.lwbrs.eq.2) - * .or. (sym(1:lsym).eq.'rd'.and.lwbrs.eq.3) - * .or. (sym(1:lsym).eq.'rp') - * .or. (sym(1:lsym).eq.'r' .and. rpfirst) -12 if (wbrest) then - ipe = ipenew - nmbr = nmbr+1 - go to 4 - else -c -c AHA! Failed prev. test, so last symbol was *not* mbr. -c It must be saved, and its starting position is ipenew-lsym+1 -c - if (nmbr .gt. 1) then -c -c Write stuff up to start of mbr -c - if (ip1 .gt. 1) write(40,'(a)')line(1)(1:ip1-1) -c -c Insert mbr symbol. Always end with a slash just in case next sym must be -c at start of block. May think this causes undefined octaves, but -c probably not since it's a single voice. -c - ndig = int(alog10(nmbr+.01))+1 - print*,'Inserting rm, iv,nmbr:',iv,nmbr - write(40,'(a2,i'//char(48+ndig)//',a2)')'rm',nmbr,' /' - if (alldone) go to 999 - ipc = ipenew-lsym+1 - line(1) = line(iline)(ipc:len) - else -c -c Write old stuff up to end of original lonesome wbr, save the rest. -c 4 cases: (wbr /) , (wbr line-end) , (wbr followed by other non-/ symbols) , -c alldone. -c In 1st 2 will have gotten some other lines, so write all up to one b4 last -c non-comment line; then revert to normal mode on that. In 3rd case must -c split line. -c - if (alldone) then - write(40,'(a)')line(1)(1:len) - go to 999 - else if (iline .gt. 1) then - do 9 il = 1 , iline-1 - len = lenstr(line(il),128) - write(40,'(a)')line(il)(1:len) -9 continue - line(1) = line(iline) - else -c -c Since iline = 1 the wbr is not the last sym, so must split -c - write(40,'(a)')line(1)(1:ip1+lwbrsx-1) - line(1) = line(1)(ip1+lwbrsx+1:len) - end if - end if -c -c Exit multibar mode -c - go to 7 - end if - end if - end if -2 continue - if (len .gt. 0) then - write(40,'(a)')line(1)(1:len) - else - write(40,'(a)')' ' - end if -1 continue -999 continue - close(10+iv) - close(40) - return - end - function ifnodur(idur,dotq) - character*1 dotq - if (idur .eq. 6) then - ifnodur=1 - else if (idur .eq. 3) then - ifnodur=2 - else if (idur.eq.1 .or. idur.eq.16) then - ifnodur=4 - else if (idur .eq. 8) then - ifnodur=8 - else if (idur .eq. 4) then - ifnodur=16 - else if (idur .eq. 2) then - ifnodur=32 - else if (idur .eq. 0) then - ifnodur=64 - else - print*,'You entered an invalid note-length value' - stop - end if - if (dotq .eq. 'd') ifnodur = ifnodur*3/2 - return - end - subroutine fwbrsym(lenbar,nwbrs,wbrsym,lwbrs) - character*3 wbrsym(2) - nwbrs = 1 - lwbrs = 2 - if (lenbar .eq. 16) then - wbrsym(1) = 'r4' - else if (lenbar .eq. 32) then - wbrsym(1) = 'r2' - else if (lenbar .eq. 64) then - wbrsym(1) = 'r0' - else if (lenbar .eq. 8) then - wbrsym(1) = 'r8' - else if (lenbar .eq. 128) then - wbrsym(1) = 'r9' - else - nwbrs = 2 - lwbrs = 3 - if (lenbar .eq. 24) then - wbrsym(1) = 'rd4' - wbrsym(2) = 'r4d' - else if (lenbar .eq. 48) then - wbrsym(1) = 'rd2' - wbrsym(2) = 'r2d' - else if (lenbar .eq. 96) then - wbrsym(1) = 'rd0' - wbrsym(2) = 'r0d' - else - write(*,'(33H Any whole-bar rests of duration ,i3, - * 26H/64 will not be recognized)') lenbar - end if - end if - return - end - subroutine nextsym(line,len,ipeold,ipenew,sym,lsym) -c -c Know its the last symbol if on return ipenew = len!. So should never -c be called when ipstart=len. -c - character*128 line - character*80 sym - if (ipeold .ge. len) then - print*,'Called nextsym with ipstart>=len ' - print*,'Send files to Dr. Don at dsimons@logicon.com' - stop - end if - do 1 ip = ipeold+1 , len - if (line(ip:ip) .ne. ' ') then -c -c symbol starts here (ip). We're committed to exit the loop. -c - if (ip .lt. len) then - do 2 iip = ip+1 , len - if (line(iip:iip) .ne. ' ') go to 2 -c -c iip is the space after the symbol -c - ipenew = iip-1 - lsym = ipenew-ip+1 - sym = line(ip:ipenew) - return -2 continue -c -c Have len>=2 and ends on len -c - ipenew = len - lsym = ipenew-ip+1 - sym = line(ip:ipenew) - return - else -c -c ip = len -c - ipenew = len - lsym = 1 - sym = line(ip:ip) - return - end if - end if -1 continue - print*,'Error #3. Send files to Dr. Don at dsimons@logicon.com' - end - function ntindex(line,s2q) -c -c Returns index(line,s2q) if NOT in TeX string, 0 otherwise -c - character*(*) s2q - character*128 line,tline - logical intex -c -c print*,'Starting ntindex. s2q:',s2q,', line(1:79) is below' -c print*,line(1:79) -c -c -c Use a temporary string to store the input and test, so can zap D"..." -c - tline = line - ndxs2 = index(tline,s2q) -c -c Return point below for rechecks after zapping D" " -c -2 continue - ndxbs = index(tline,char(92)) - if (ndxbs .gt. 0) then -c -c Special check in case \ is inside D"..." -c - ndxDq1 = index(tline,'D"') -c -c If the following test fails, flow out of if block; else loop up to 2. -c - if (ndxDq1 .gt. 0) then -c -c Find end of D"..." -c - ndxDq2 = ndxDq1+1+index(tline(ndxDq1+2:128),'"') - if (ndxDq2 .eq. ndxDq1+1) then - print*,'Something is really wierd here' - stop - end if - tline = tline(1:ndxDq1-1) - do 3 ic = ndxDq1 , ndxDq2 - tline = tline(1:ic-1)//' ' -3 continue - tline = tline(1:ndxDq2)//line(ndxDq2+1:128) - go to 2 - end if - end if - if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then - ntindex = ndxs2 -c print*,'No bs, or char is left of 1st bs, ntindex:',ntindex - else -c -c There are both bs and s2q, and bs is to the left of sq2. So check bs's to -c right of first: End is '\ ', start is ' \' -c - len = lenstr(tline,128) - intex = .true. -c print*,'intex+>',intex - do 1 ic = ndxbs+1 , len - if (ic .eq. ndxs2) then - if (intex) then - ntindex = 0 - ndxs2 = index(tline(ic+1:len),s2q)+ic -c print*,'ndxs2 =>',ndxs2 - else - ntindex = ndxs2 - return - end if -c print*,'Internal exit, intex, ntindex:',intex,ntindex - else if (intex .and. tline(ic+1:ic+2).eq.char(92)//' ') then - intex = .false. -c print*,'intex+>',intex - else if (.not.intex .and. tline(ic+1:ic+2).eq.' '//char(92)) - * then - intex = .true. -c print*,'intex+>',intex - end if -1 continue -c print*,'Out end of loop 1' - end if -c print*,'Exiting ntindex at the end???' - return - end - subroutine getchar(line,iccount,charq) -c -c Gets the next character out of line*128. If pointer iccount=128 on entry, -c then reads in a new line. Resets iccount to position of the new character. -c - character*1 charq - character*128 line - if (iccount .eq. 128) then - read(10,'(a)')line - iccount = 0 - end if - iccount = iccount+1 - charq = line(iccount:iccount) - return - end - function readin(line,iccount,iread) - parameter (noimax=24) - common /all/ noinow,iorig(noimax),noinst,insetup,replacing, - * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow - logical insetup,replacing,botv -c -c Reads a piece of setup data from line, gets a new line from -c file 10 (jobname.pmx) if needed, Transfers comment lines into all parts. -c -c iread controls copying of values into scratch files for parts, but only -c if not replacing. -c -c iread input value written -c -1 nvi nothing (only used when noinst<0 initially) -c 0 various value read -c 1 nv -1 , replace later with nvi(i) -c 2 noinst 1 -c 3 np -2 , replace later with (nsyst-1)/12+1 -c 4 musicsize 20 -c 5 fracondent 0.05 -c - character*128 line - character*1 durq -4 if (iccount .eq. 128) then - read(10,'(a)')line - if (replacing) replacing = .false. - call chkcom(line) - iccount = 0 - end if - iccount = iccount+1 -c -c Find next non-blank or end of line -c - do 2 iccount = iccount , 127 - if (line(iccount:iccount) .ne. ' ') go to 3 -2 continue -c -c If here, need to get a new line -c - iccount = 128 - go to 4 -3 continue -c -c iccount now points to start of number to read -c - i1 = iccount -5 call getchar(line,iccount,durq) -c -c Remember that getchar first increments iccount, *then* reads a character. -c - if (index('0123456789.-',durq) .gt. 0) go to 5 - i2 = iccount-1 - if (i2 .lt. i1) then - print*,'Found "'//durq//'" instead of number' - stop 1 - end if - icf = i2-i1+49 - read(line(i1:i2),'(f'//char(icf)//'.0)')readin - if (.not.replacing) then - if (iread .eq. 0) then - call allparts(line(i1:i2),i2-i1+1) - else if (iread .eq. 1) then - call allparts('-999',4) - else if (iread .eq. 2) then - call allparts('1',1) - else if (iread .eq. 3) then - call allparts('-998',4) - else if (iread .eq. 4) then - call allparts('20',2) - else if (iread .eq. 5) then - call allparts('.05',3) - else if (iread .ne. -1) then - print*,'Error with iread in readin' - stop - end if - end if - return - end - subroutine chkcom(line) - parameter (noimax=24) - common /all/ noinow,iorig(noimax),noinst,insetup,replacing, - * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow - logical insetup,replacing,clefpend,botv - character*128 line -c -c Assume that line has just been read. No need to change iccount since we only -c process full lines. -c -1 if (line(1:1) .ne. '%') return -c -c If here, line has some sort of comment -c - if (line(2:2) .eq. '%') then - if (.not. insetup) then -c -c Suck up a line, then flow out of "if" block to get another and loop -c - read(10,'(a)')line - -c++VV -c -c UNLESS (a) it has a score-only "M" and changes # of inst's. -c - if (index(line,'M') .gt. 0) then - idxL = index(line,'L') - idxM = index(line,'M') - idxn = index(line,'n') - idxb = index(line,' ') - if (idxL.lt.idxM .and. idxM.lt.idxn .and. - * (idxb.eq.0 .or. idxn.lt.idxb)) then - noinow = ichar(line(idxn+1:idxn+1))-48 - clefpend = .true. -c -c Next noinow digits are original inst. #'s of new inst. set. Next noinow -c char's after that are clefs -c - nvnow = 0 - do 24 j = 1 , noinow - iorig(j) = ichar(line(idxn+1+j:idxn+1+j))-48 - iposc0 = idxn+1+noinow - do 25 k = 1 , nvi(iorig(j)) - nvnow = nvnow+1 -c clefq(nvnow) = line(iposc0+nvnow:iposc0+nvnow) - instnum(nvnow) = j - botv(nvnow) = k.eq.1 .and. j.ne.1 -25 continue -24 continue - end if - end if -c -c or if it's "h" or "l", need to suck up one more line -c - if ((line(1:1).eq.'h'.and.index('+- ',line(2:2)).gt.0) .or. -c -c 4/29/00 check for T string also -c - * line(1:1).eq.'T' .or. - * line(1:2).eq.'l ') read(10,'(a)')line - else -c -c In setup mode. Set flag, flow out and do use following line -c - replacing = .true. - end if - else if (line(2:2) .eq. '!') then -c -c Copy to all parts -c - call allparts(line(3:128),125) - else -c -c Get value of hex integer 1,2,...,9,a,b,c in 2nd position, zero otherwise -cc Get value of extended hex integer 1,2,...,9,a,b,c,...,o in 2nd position, zero otherwise -c - ivq = index('123456789abcdefghijklmno',line(2:2)) -c -c Only treat as part-specific pmx line if number .le. noinst -c - if (ivq.lt.1 .or. ivq.gt.noinst) then -c -c Simple comment. -c - call allparts(line,128) - else -c -c Instrument comment, copy only to part -c - lenline = lenstr(line,128) - if (lenline .gt. 2) then - write(10+ivq,'(a)')line(3:lenline) - else -c -c Transferring blank line -c - write(10+ivq,'(a)')' ' - end if - end if - end if - read(10,'(a)',end=2)line - call zapbl(line,128) - go to 1 -2 continue - return - end - subroutine dosetup(iv,line,mtrnum,mtrden) - parameter (noimax=24) -c -c Transfers setup data from scratch file to real one for one instrument -c Data may be mixed with comments, but on entry 1st item is a number. -c Write a comment when encountered, as it comes. -c Write numbers one per line. -c Three input data require special handling: -c If not already replaced, i.e., if negative, then -c iset(1) (nv) will be replaced with nvi(i) -c iset(9) (npages) will be replaced with (nsyst-1)/12+1 -c iset(2), if negative, will be followed by extra numbers to be transf. -c - common /all/ noinow,iorig(noimax),noinst,insetup,replacing, - * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow - character*128 line - iccount = 0 - do 1 iset = 1 , 12 - call partnum(iv,iccount,line,xdata) - if (iset .eq. 2) then - if (xdata .gt. 0) then - write(40,'(i5)')int(xdata+.1) - else - noi = -xdata+.1 - write(40,'(i5)')noi - do 2 ioi = 1 , noi - call partnum(iv,iccount,line,xdata) - write(40,'(i5)')int(xdata+.1) -2 continue - end if -c else if (iset.ne.8 .and. xdata.lt.0) then - else if (iset.ne.8 .and. iset.ne.5 .and. xdata.lt.0) then -c -c Must be either nv or npages -c - if (int(-xdata+.1) .eq. 999) then -c -c It's nv -c - write(40,'(i5)')nvi(iv) - else -c -c npages must be computed -c - write(40,'(i5)')(nsyst-1)/12+1 - end if - else if (iset.ne.7 .and. iset.ne.12) then -c -c write integer -c - write(40,'(i5)')nint(xdata) - else -c -c write floating number -c - write(40,'(f5.2)')xdata - end if - if (iset .eq. 3) then - mtrnum = nint(xdata) - else if (iset .eq. 4) then - mtrden = nint(xdata) - end if -1 continue - return - end - subroutine partnum(iv,iccount,line,xdata) -c -c Simplified number parsing. Only looks for comment lines and numbers. -c - character*128 line - character*1 durq -2 if (iccount .eq. 128) then - read(10+iv,'(a)')line - if (line(1:1) .eq. '%') then - len = lenstr(line,128) - write(40,'(a)')line(1:len) - go to 2 - end if - iccount = 0 - end if - iccount = iccount+1 -c -c Find next non-blank or end of line -c - do 4 iccount = iccount , 127 - if (line(iccount:iccount) .ne. ' ') go to 3 -4 continue -c -c If here, iccount=128 and need to get a new line -c - go to 2 -3 continue -c -c iccount now points to start of number to read -c - i1 = iccount -5 call getchar(line,iccount,durq) -c -c Remember that getchar first increments iccount, *then* reads a character. -c - if (index('0123456789.-',durq) .gt. 0) go to 5 - i2 = iccount-1 - if (i2 .lt. i1) then - print*,'Found "'//durq//'" instead of number' - stop 1 - end if - icf = i2-i1+49 - read(line(i1:i2),'(f'//char(icf)//'.0)')xdata - return - end - block data - parameter (noimax=24) - common /all/ noinow,iorig(noimax),noinst,insetup,replacing, - * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow - logical insetup,replacing,botv - data nvi /noimax*1/, noinst,noinow /2*noimax/ - data botv /noimax*.false./ - end - subroutine zapbl(string,len) - character*(*) string - do 1 i = 1 , len - if (string(i:i) .eq. ' ')go to 1 - if (i .eq. 1) return - go to 2 -1 continue -c -c If line is all blank, leave it alone -c - return -2 continue - string = string(i:len) - return - end - subroutine OddQuotesBefore(lineq,indx,yesodd) -c -c This counts number of double quotes in lineq up to position indx-1, then -c sets yesodd according to whether number is odd or even -c - logical yesodd - character*(*) lineq - numdqs = 0 - do 1 i = 1 , indx-1 - if (lineq(i:i) .eq. '"') numdqs = numdqs+1 -1 continue - yesodd = mod(numdqs,2) .eq. 1 - return - end - - - - - |