/*Translated by FOR_C, v3.4.2 (-), on 07/09/115 at 08:30:08 */
/*FOR_C Options SET: ftn=u io=c no=p op=aimnv s=dbov str=l x=f - prototypes */
#include <math.h>
#include "fcrt.h"
#include "mess.h"
#include <string.h>
#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>
/*++ CODE for .C. is active */
static FILE *c_handle[2], *scratch_file;
static char *c_fname[2]={"MESSF-xx", "MESSF-xx"};
char *ctmp;
#include <string.h>
/* PARAMETER translations */
#define LENBUF 250
#define LNERR 79
#define LNMSG 128
#define MECONT 50
#define MEGBAS 49
#define MEGMAT 64
#define MEGVCI 68
#define MEIMAT 58
#define MEIVCI 65
#define MEIVEC 57
#define MEJMAT 60
#define MEMAXI 68
#define MENTXT 23
#define MERET 51
#define MESUNI 10
#define MEVBAS 10
#define MEVLAS 33
#define SC '$'
/* end of PARAMETER translations */
/* COMMON translations */
struct t_messcc {
long int kciwid, kccwid, kcrwid, lbeg, lend, lfprec, lgprec;
} messcc;
struct t_cmessi {
long int sunit, lhead, kdfdef, linmsg, linerr, munit, eunit, kscrn,
kdiag, maxerr, lstop, lprint, kdf, ntext, nidat, nfdat, nmdat,
mdat[5], tabspa, errcnt, ichar0, imag, inc, irc, itext, iwf,
iwg, kdi, kdj, kline, kshift, kspec, kt, lasti, lbuf, lenlin,
lenout, lentry, lentxt, locbeg, lstrt, ltext, maxwid[2], mpt,
nrow, ncol, ndim, ounit;
LOGICAL32 gotfmt, xarg, xargok;
} cmessi;
struct t_cmessc {
char buf[251], dols[73], fmtf[21], fmtg[16], fmti[8], fmtj[8],
fmtt[16], fmtim[2][8];
} cmessc;
/* end of COMMON translations */
void /*FUNCTION*/ mess(
long mact[],
char *text, int text_s,
long idat[])
{
#define TEXT(I_,J_) (text+(I_)*(text_s)+(J_))
char _c0[2];
LOGICAL32 getw;
byte c;
long int iout, itextr, j, jj, k, k1, k2, kk, kp, ks, lbuf1, lbuf2,
messgs();
static long int i, icol, irow, irow1, itxtsv, kdilab, knt, lasknt,
m, nline, nskip, ntextr, ntxtsv;
static long inerr = 0;
static LOGICAL32 first = TRUE;
static char ermsg[64] = " reports error: Stop level = x, Print level = y, Error index = ";
static char ermsg1[28] = ": Print level = y, Index = ";
static long incm[MEIMAT-(MECONT)+1]={1,1,4,1,2,0,0,2,6};
static long mbndlo[MEVLAS-(MEVBAS)+1]={0,0,-50,39,39,-99,-99,0,
0,0,0,0,-50,1,1,1,1,-1000000000,-1000000000,-1000000000,-1000000000,
-1000000000,1,0};
static long mbndhi[MEVLAS-(MEVBAS)+1]={99,1,50,500,500,99,99,100000000,
1000000000,1000000000,8,8,50,10000000,1000000000,1000000000,5,
1000000000,1000000000,1000000000,1000000000,1000000000,100,1000000000};
/* EQUIVALENCE translations */
static long _es0[2];
long int *const ivar = (long*)&cmessi.sunit;
long int *const kolwid = (long*)((long*)cmessi.maxwid + 1);
long int *const linstr = (long*)cmessi.maxwid;
long int *const mtext = (long*)_es0;
long int *const mtextc = (long*)((long*)_es0 + 1);
long int *const mtextr = (long*)_es0;
long int *const nroco = (long*)&cmessi.nrow;
/* end of EQUIVALENCE translations */
/* OFFSET Vectors w/subscript range: 1 to dimension */
long *const Idat = &idat[0] - 1;
long *const Mact = &mact[0] - 1;
long *const Maxwid = &cmessi.maxwid[0] - 1;
long *const Mdat = &cmessi.mdat[0] - 1;
long *const Mtext = &mtext[0] - 1;
long *const Nroco = &nroco[0] - 1;
/* end of OFFSET VECTORS */
/*++ END
* Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
* ALL RIGHTS RESERVED.
* Based on Government Sponsored Research NAS7-03001.
*>> 2010-02-22 MESS Krogh Moved NSKIP=0 to start of code.
*>> 2009-10-30 MESS Krogh Defined DSCRN.
*>> 2009-02-28 MESS Krogh Added FMTT = ' ' for NAG compiler.
*>> 2009-02-28 MESS Krogh Fixed "f" format for C code.
*>> 2007-09-08 MESS Krogh Fixed definitions of MEVLAS.
*>> 2006-07-27 MESS Krogh Fixed boundary case in printing long text.
*>> 2006-03-20 MESS Krogh Added code for output of sparse vector.
*>> 2005-04-07 MESS Krogh Declared LFLGDB integer in MESSMH.
*>> 2004-12-15 MESS Krogh Added " - 1" at end of line on label 410.
*>> 2002-05-17 MESS Krogh Added way for user to get error count.
*>> 2001-12-28 MESS Krogh Added NSKIP for more flexible output values.
*>> 2000-12-30 MESS Krogh Fixed some types/casts in C code.
*>> 1997-12-12 MESS Krogh Prefixed 0P edit descriptor to F format.
*>> 1996-07-11 MESS Krogh Transpose matrix output for C.
*>> 1996-06-27 MESS Krogh fprintf(stdout, => printf( & memset now used
*>> 1996-06-18 MESS Krogh "Saved" NTEXTR.
*>> 1996-05-15 MESS Krogh Changes to use .C. and C%%.
*>> 1996-03-30 MESS Krogh Added external statement.
*>> 1996-01-24 MESS Krogh Fixed minor bug introduced with "$ " stuff.
*>> 1996-01-23 MESS Krogh Minor changes for C conversion.
*>> 1995-11-10 MESS Krogh Add code to change "$ " to " " in headings.
*>> 1995-08-11 MESS Krogh Made code default to not using UMESS.
*>> 1995-01-20 MESS Krogh Fixed unusual case in matrix output.
*>> 1994-12-15 MESS Krogh Removed block data for Cray T3D.
*>> 1994-11-11 MESS Krogh Declared all vars.
*>> 1994-09-14 MESS Krogh Fixed to get 1 more "$" in C output.
*>> 1994-09-08 MESS Krogh Added new matrix/vector capabilities.
*>> 1994-08-22 MESS Krogh Fix for conversion to C for new converter.
*>> 1994-07-05 MESS Krogh Fixed bug, KDI and FMTI could be inconsist.
*>> 1994-05-20 MESS Krogh Changes to MESSFT so line 1 can go to file.
*>> 1994-05-20 MESS Krogh Changes to setting output unit.
*>> 1994-05-09 MESS Krogh Integer vectors had overflow & space probs.
*>> 1993-05-19 MESS Krogh Changed TEXT to array of character strings.
*>> 1993-04-14 MESS Krogh Fixes for conversion to C. (C%% comments.)
*>> 1993-03-10 MESS Krogh Broke into smaller pieces.
*>> 1992-12-02 MESS Krogh Added save statement to block data subpr.
*>> 1992-07-13 MESS Krogh Add checks in heading set up.
*>> 1992-07-12 MESS Krogh Fixed so $$ prints a single $ in TEXT.
*>> 1992-07-12 MESS Krogh Set out of bound inputs to limit values.
*>> 1992-07-12 MESS Krogh Fixed so output works to alternate files.
*>> 1992-07-12 MESS Krogh Added integer declarations for parameters.
*>> 1992-06-24 MESS Krogh More blanks allowed on break of long lines.
*>> 1992-06-10 MESS Krogh Minor fix to vector output.
*>> 1992-05-27 MESS Krogh Fixed bug on line width setting.
*>> 1992-05-14 MESS Krogh Put common blocks in save statement.
*>> 1992-05-11 MESS Krogh Added label to assigned go to & a comment.
*>> 1992-04-08 MESS Krogh Unused labels 60, 220 and 320 removed.
*>> 1992-03-20 MESS Krogh Changed status on open to SCRATCH.
*>> 1992-03-10 MESS Krogh 1 line below label 690 changed max to min.
*>> 1992-02-05 MESS Krogh Fixed bugs in printing matrix labels.
*>> 1992-01-29 MESS Krogh Added UMESS and multiple print option.
*>> 1991-12-09 MESS Krogh Fine tuning of vector output.
*>> 1991-10-10 MESS Krogh Insure no stop if stop level = 9.
*>> 1991-06-26 MESS Krogh Initial Code.
* Processes Messages -- Actions are controlled by MACT().
* This routine is intended for use primarily by other library routines.
* Users of library routines may want to use values of MACT from MERET-
* MESUNI, and may have an interest in using it to print messages
* from their own software.
* This routine has companion routines that are called with the same
* three arguments, plus one additional argument. This argument is
* referred to here as FDAT since actions specified here can result
* in returns to print data from FDAT. The name FDAT is used because
* this other routine will ordinarily print floating point data, but
* it could also print other kinds of data, e.g. logical. At present
* only SMESS and DMESS are defined which are for single and double
* precision floating point data.
* MACT is a vector specifying sequentially the actions desired.
* Some of these actions require more than one location, in which
* case the next action follows the last datum required by the
* previous action. Internal variables together with default
* values in parentheses which are used to keep track of locations
* are as follows:
* NTEXT (1) The next text output starts at TEXT(NTEXT).
* NIDAT (1) The next output from IDAT starts at IDAT(NIDAT).
* NFDAT (1) The next output from FDAT starts at FDAT(NFDAT).
* NMDAT (1) The next output from MDAT starts at MDAT(NMDAT), where
* MDAT is defined by actions MEMDA1-MEMDA5 below, and
* NMDAT is set to one at end of every text output.
* An action which uses data pointed to by one of the above will cause
* the pointer to be incremented to one past the last location used. An
* exception is NMDAT which when it reaches 5 is not incremented and the
* value pointed to is incremented instead.
* Actions are encoded by values starting in MACT(1) as follows.
* (Arguments required are given in parentheses at the start of
* description. These arguments follow the action index. The next
* action follows the last argument for the preceding action. Action
* indices have been selected so that it is easy to add new functionality
* without affecting codes using an earlier version. Where bounds are
* indicated for an argument, if the argument is outside the bounds it is
* treated as if it had the value for the bound violated.)
* MESUNI=10 (0 .le. K10 .le. 99) Set the unit to use for a scratch
* file. The default unit for a scratch file is 30. If a
* scratch file is needed, (only needed here if a table
* exceeds the line length), and unit 30 can not be opened as
* a new scratch file, then units 29, 28, ..., will be tried */
/* until an acceptable unit is found. Library routines may
* use this file but must be sure that the use does not
* conflict with the printing of tables here, or the use by
* any other library routines. If K10 is 0, a scratch unit is
* assumed not to be available, and tables with long lines
* will be printed with each line on multiple lines.
* MEHEAD=11 (0 .le. K11 .le. 1) Defines the print that surrounds an
* error message. K11=0 gives nothing, and 1 gives the first
* 4 characters in TEXT repeated 18 times. If this is not
* used, one gets 72 $'s. (To get a blank line use 1 with
* TEXT = ' '.)
* MEDDIG=12 (-50 .le. K12 .le. 50) Set default digits to print for
* floating point. If K12 > 0 then K12 significant digits
* will be printed, if K12 < 0, then -K12 digits will be
* printed after the decimal point, and if K12 = 0, the
* default will be used, which is the full machine precision.
* Setting or getting this value will only work properly if
* the action is taken by calling SMESS or DMESS as
* appropriate.
* MEMLIN=13 (39 .le. K13 .le. 500) Set message line length to K13.
* (Default is 128.)
* MEELIN=14 (39 .le. K14 .le. 500) Set error message line length to
* K14. (Default is 79)
* MEMUNI=15 (-99 .le. K15 .le. 99) Messages go to unit K15. If K15 = 0
* (default), 'print' is used. If K15 < 0, messages go to
* both 'print' and to unit abs(K15). If a write can not be
* done to unit abs(K15), this unit will be opened with file
* name MESS_Fxx.tmp, where xx is the value of abs(K15).
* MEEUNI=16 (-99 .le. K16 .le. 99) As for MEMUNI, except for Error
* Messages.
* MESCRN=17 (0 .le. K17 .le. 100000000) Set number of lines to print to
* standard output before pausing for "go" from user. Default
* is 0, which never stops.
* MEDIAG=18 (0 .le. K18 .le. 1000000000) Set the diagnostic level
* desired. This routine makes no use of K18. It merely
* serves as a place to set it and to answer inquiries on its
* value. It is intended to be set by users of library
* software. Library packages that make use of this number
* are expected to use it as described below. If K18 = 0 (the
* default), no diagnostic print is being requested. Else m =
* mod(K18, 256) determines whether a package will do
* diagnostic printing. Associated with a library package is
* a number L which must be a power of 2 < 129, and which
* should be mentioned in the documentation for the package.
* If the bit logical or(m,L) = L then diagnostic output for
* the routine with the associated value of L is activated.
* The value of L should have been selected by the following
* somewhat vague rules. Let base 2 log(L) = 2*i + j, where j
* is 0 or 1. Select i = level of the library package, where
* the level is 0 if no other library routine that is likely
* to be used with the package could reasonably be expected to
* want any embedded diagnostics, and otherwise is
* min(4, I+1), where I is the maximum level for any library
* routine which is likely to be used with the package.
* Select j = 0 if the user is relatively unlikely to want
* diagnostics, and j = 1, if this is a routine for which
* considering its level the user is relatively likely to want
* diagnostic output. The next 8 bits, mod(K18/256, 256), may
* be used by the library routine to select the actual output
* that is to be given. These bits may be ignored, but if
* they are used, the lowest order bits should correspond to
* less voluminous output that is more likely to be requested.
* Finally, K18 / (2**16) may be used to give a count on how
* many times to print the diagnostics that are given. This
* count may be interpreted by library routines in slightly
* different ways, but when used it should serve to turn off
* all output after a certain limit is reached. By
* convention, if this is 0 there is no upper bound on the
* count.
* MEMAXE=19 (0 .le. K19 .le. 1000000000) Set the maximum error value.
* When retrieving this value, it is the maximum value seen
* for 10000*s + 1000*p + i, where s, p, and i are the stop
* and print levels, and the index on the last error message
* processed, respectively. See MEEMES below.
* MESTOP=20 (0 .le. K20 .le. 8) Set the stop level for error messages.
* If an error message has a stop index > min(K20, 8), the
* program is stopped after processing the message. The
* default value is K20=3.
* MEPRNT=21 (0 .le. K21 .le. 8) Set the print level for error messages.
* If an error message has a print index > K21, or the message
* is going to stop when finished, information in an error
* message is processed, else all the actions including
* printing are skipped. (MESTOP controls stopping.) The
* default value is MEPRNT = 3.
* An action index of -i, for i < METDIG, will return in the location
* ordinarily used for Ki the current default value for the internal
* variable set by Ki. In the case of MESUNI, if the scratch unit has
* not been opened, it will be opened before returning the unit number.
*
* METDIG=22 (-50 .le. K22 .le. 50) As for MEDDIG, except the value here
* is temporary, lasting until the return, or next use of this
* action. If 0, the internal value for K12 is used instead.
* MENTXT=23 (1 .le. K23 .le. 10000000) Set value of NTEXT to K23.
* MEIDAT=24 (1 .le. K24 .le. 1000000000) Set value of NIDAT to K24.
* MEFDAT=25 (1 .le. K25 .le. 1000000000) Set value of NFDAT to K25.
* MEMDAT=26 (1 .le. K26 .le. 5) Set value of NMDAT to K26.
* MEMDA1=27 (K27) set MDAT(1) to K27. See description of NMDAT above.
* MEMDA2=28 (K28) set MDAT(2) to K28.
* MEMDA3=29 (K29) set MDAT(3) to K29.
* MEMDA4=30 (K30) set MDAT(4) to K30. */
/* MEMDA5=31 (K31) set MDAT(5) to K31.
* METABS=32 (1 .le. K32 .le. 100) set spacing for tabs to K32.
* MECONT=50 Exit, but no print of current print buffer. The error or
* diagnostic message is to be continued immediately.
* MERET=51 All done with diagnostic or error message, complete
* processing and return, or for some error messages stop.
* MEEMES=52 (K52, L52, M52) Start an error message with severity level
* K52,index for the error of L52, and message text starting
* at TEXT(M52). If M52 is 0, message text starts at
* TEXT(NTEXT), and if M52 < 0, no message text is
* printed as part of this action. Library routines should
* set K52 = 10*s + p, where s is the stop level desired, and
* p the print level, and should have 10 > p .ge. s .ge. 0.
* We offer the following guidelines as a yardstick for
* setting the value of s.
* = 9 User has ignored warning that program was going to be stopped.
* = 8 Program has no way to continue.
* = 7 User has given no indication of knowing that functionality of
* results is reduced. (E.g. not enough space for some result.)
* = 6 Program could continue but with reduced functionality.
* = 5 Results far worse than user expected to want.
* = 4 User has given no indication of knowing that results do not
* meet requested or expected accuracy.
* = 3 Warning is given that program will be stopped without some
* kind of response from the calling program.
* = 2 Program is not delivering requested or expected accuracy.
* = 1 Some kind of problem that user could correct with more care in
* coding or in problem formulation.
* = 0 Message is for information of uncritical nature.
* Print levels might be counted down so that warnings given
* several times are no longer given, or be counted up so
* that a warning is only given after a certain threshold is
* reached. Levels should be selected with the understanding
* that the default is to print only levels above 3.
* METEXT=53 Print TEXT, starting at TEXT(NTEXT). Print ends
* with the last character preceding the first '$'. Special
* actions are determined by the character following the '$'.
* Except as noted, the '$' and the single character which
* follows are not printed. In the text below, "to continue",
* means to continue print of TEXT with the next character
* until the next "$". Except for the one case noted, NTEXT
* is set to point to the second character after the "$".
* Note, letters must be in upper case. Possibilities are:
* B Break text, but don't start a new line.
* E End of text and line.
* R Break text, don't change the value of NTEXT. Thus next
* text Repeats the current.
* N Start a New line, and continue.
* I Print IDAT(NIDAT), set NIDAT=NIDAT+1, and continue.
* J As for I above, except use the last integer format
* defined by a "$(", see below.
* F Print FDAT(NFDAT), set NFDAT=NFDAT+1, and continue.
* G As for F above, except use the last floating format
* defined by a "$(", see below.
* M Print MDAT(NMDAT), set NMDAT=NMDAT+1, and continue.
* H Marks terminator for column and row Headings, see table,
* vector, and matrix output below. This causes enough blanks to
* be generated to keep column headings centered over their
* columns. After the blanks are generated, text is continued
* until the next '$'. This is not to be used except inside
* column or row headings. The last row or column should be
* terminated with a '$E' or if appropriate, a '$#' for a row or
* column label.
* ( Starts the definition of a format for integer or floating
* point output. The format may not contain a "P" field, and
* must require no more than 12 characters for floating point
* (e.g. "(nnEww.ddEe)", where each of the lower case letters
* represents a single digit), and no more than 7 characters for
* integer output. Following the ")" that ends the format, if
* the next character is not a "$" then "$J" or "$G" type output
* is done, see above. In either case processing of TEXT then
* continues.
* T Tab.
* # Used in matrix row or column labels this prints the current
* row or column index, respectively, ends the text for the
* current row or column, and resets the text pointer to where
* it started.
* $ a single '$' is printed, continue till the next '$'.
* - Start a negative number for skipping.
* 0-9 Digits for skipping.
* C Only used by PMESS which deletes it and the preceding '$'.
* Used at the end of a line to indicate continued text.
* other Don't use this -- the '$' is ignored, but new features may
* change the action. (E.g. $P might be added to get a prompt.)
* ME????=54 Not used.
* METABL=55 (K55, L55, M55, N55) Note this action automatically
* returns when done, further locations in MACT are not
* examined. This action prints a heading and/or data that
* follows a heading. If K55 is 1, then the heading text
* starting in TEXT(NTEXT) is printed. This text
* should contain embedded "$H"'s to terminate columns of the
* heading. If there is no heading on a column, use " $H".
* Note the leading blank. If the heading is to continue
* over k columns, begin the text with "$H" repeated k-1
* times with no other embedded characters. The very last
* column must be terminated with "$E" rather than "$H".
* After tabular data is printed, K55 is incremented by 1,
* and compared with L55. If K55 > L55, K55 is reset to 1,
* and if the data that was to be printed had lines that were
* too long, data saved in the scratch file is printed using */
/* the headings for the columns that would not fit on the
* first pass. Note that only one line of tabular data can
* be printed on one call to this subroutine.
* M55 gives the number of columns of data associated with the
* heading.
* N55 is a vector containing M55 entries. The k-th integer
* in N55 defines the printing action for the k-th column
* of the table. Let such an integer have a value defined by
* rr + 100 * (t + 10 * (dd + 100 * ww)), i.e. wwddtrr, where
* 0 .le. rr,dd,ww < 100, and 0 .le. t < 10.
* rr The number of items to print.
* t The type of output.
* 1 Print text starting at TEXT(NTEXT), rr = 01.
* 2 Print the value of K55, rr = 01.
* 3 Print integers starting at IDAT(NIDAT).
* 4 Print starting at FDAT(NFDAT), using an F format.
* 5 Print starting at FDAT(NFDAT), using an E format.
* 6 Print starting at FDAT(NFDAT), using an G format.
* dd Number of digits after the decimal point.
* ww The total number of column positions used by the column,
* including the space used to separate this column from the
* preceding one. This must be big enough so that the column
* headings will fit without overlap.
* MEIVEC=57 (K57) Print IDAT as a vector with K57 entries. The vector
* output starts on the current line even if the current line
* contains text. This is useful for labeling the vector.
* The vector starts at IDAT(NIDAT).
* If K57 < 0, indices printed in the labels for the vector
* start at at NIDAT, and entries from NIDAT to -K57 are
* printed.
* MEIMAT=58 (K58, L58, M58, I58, J58) Print IDAT as a matrix with K58
* declared rows, L58 actual rows, and M58 columns. If K58<0,
* instead of using 1 for the increment between rows, and K58
* for the increment between columns, -K58 is used for the
* increment between rows, and 1 is used for the increment
* between columns. If L58<0, the number of actual rows is
* mod(-L58, 100000), and the starting row index is -L58 /
* 100000. Similarly for M58<0. TEXT(I58) starts the text for
* printing row labels. If I58 < 0, no row labels are
* printed. If I58 = 0, it is as if it pointed to text
* containing "Row $E". Any "$" in a row or column label must
* be followed by "H" or "E" which terminates the text for the
* label. In the case of $H, text for the next label follows
* immediately, in the case of $E the current row index is
* printed in place of the $E and the next label uses the same
* text. J58 is treated similarly to I58, except for column
* labels, and with "Row $E" replaced with "Col $E". The
* matrix starts at IDAT(NIDAT), and NIDAT points one past the
* end of the matrix when finished.
* MEJVEC=59 (K59) As for MEIVEC, except use format set with $(.
* MEJMAT=60 (K60, L60, M60, I60, J60) As for MEIMAT, except use the
* format set with $(.
* MEFVEC=61 (K61) As for MEIVEC, except print FDAT as a vector with
* K61 entries. The vector starts at FDAT(NFDAT).
* MEFMAT=62 (K62, L62, M62, I62, J62) As for action MEIMAT, but
* instead print FDAT, and use NFDAT in place of NIDAT.
* MEGVEC=63 (K63) As for MEFVEC, except use format set with $(.
* MEGMAT=64 (K64, L64, M64, I64, J64) As for MEIMAT, except use the
* format set with $(.
* MEIVCI=65 (K65, L65) As for MEIVEC, except the vector entries have a
* spacing of K65, and there are L65 entries in the vector.
* MEJVCI=66 (K66) As for MEIVCI, except use format set with $(.
* MEFVCI=67 (K67, L67) As for MEFVEC, except the vector entries have a
* spacing of K67, and there are L67 entries in the vector.
* MEGVCI=68 (K68) As for MEFVCI, except use format set with $(.
* MEFSPV=69 (K69) Output IDAT, FDAT as a sparse vector.
*
*
* ************************** Internal Variables ************************
*
* BUF Character string holding characters to be output.
* C Used for temp. storage of a character.
* DOLS A heading/trailing string of characters, default = $'s.
* ERMSG Default part of error message.
* ERRCNT Used to keep a count of error messages.
* EUNIT Unit number for output of error messages.
* FDAT Formal array, containing floating point data to output. Only
* appears external to this subroutine.
* FIRST Set = .true. initially, then .false. after MESS is called.
* FMTC Format for integer output of matrix column headings.
* FMTF Format for floating point or other output.
* FMTG Format set by user for floating point or other output.
* FMTI Character string holding format for integer output.
* FMTIM Equivalenced to FMTR, FMTC.
* FMTJ Format set by user for integer output.
* FMTR Value of FMTI for format of row indices.
* FMTT Format to be stored in FMTJ or FMTG.
* GETW Set true if still need to get width for a format.
* GOTFMT Set .true. if format has been set by user. When printing
* tables, set true when heading has been output.
* I Index of current action from MACT.
* ICHAR0 Value of ICHAR('0')
* ICOL Current column index in matrix output.
* IDAT Formal array, containing integer data to output.
* IMAG Magnitude of integer to output, with negative sign if integer
* is < 0.
* INC Increment between successive elements in a vector or in the
* column of a matrix.
* INCM Array giving amount of space used by the options.
* INERR 0 if not processing an error message, 1 if printing an error */
/* message, -1 if in an error message that is not being printed, and >1
* if printing an error message that stops. Set to -2 when the error
* message is supposed to stop.
* IOUT Integer to be output.
* IRC = 1 for rows, = 2 for columns when determining labels for
* matrix output.
* IROW Row index for matrix output. Also used in table output to
* count lines for printing line index on read from scratch unit.
* IROW1 Starting row index for matrix output.
* ITEXT Index of the element of TEXT use for the next text output.
* ITXTSV Saved value of NTEXT when doing matrix output.
* IVAR Integer array, that is equivalenced to a number of integer
* variables that can be set by the user.
* IWF Width to be used in a floating pt. (or other) format.
* IWG Value like IWF for user set format.
* J Used as a temporary index.
* JJ Used as a temporary index.
* K Used as a temporary index.
* K Used as a temporary index.
* K1 Used as a temporary index.
* K2 Used as a temporary index.
* KDF Current number of digits to print for floating point. See
* description of MACT(*) = METDIG above.
* KDFDEF Current default for KDF, see description of MACT(*) = MEDDIG.
* KDI Number of digits used to print last integer.
* KDIAG Not directly referenced. Holds place in IVAR for reference
* from outside. See comments above.
* KDILAB Length for printing index in vector output.
* KDJ As for KDI, except for format set by user.
* KK Temporary index.
* KLINE Count of number of things to print on a line. (In table print
* is the number to print for one spec field.)
* KNT In vector output gives the current index for output.
* KOLWID Length to use for printing a column heading. Equivalenced to
* MAXWID(2).
* KP Index from error action input for the print action.
* KRES1 Holds place in common block for future use.
* KS Index from error action input for the stop action.
* KSCRN Number of lines to "print" before pausing.
* KSHIFT Amount to shift column heading before printing.
* KSPEC Defines action after looking for character in TEXT. (Also
* used as a temporary index.)
* 1. $B Break the text here continue on same line.
* 2. $E Break text, print what is in BUF.
* 3. $R Break text, continue on same line, NTEXT set to repeat the
* current text.
* 4. $N Print BUF, continue with following text.
* 5. $I Print IDAT(NIDAT), continue TEXT.
* 6. $F Print FDAT(NFDAT), continue TEXT.
* 7. $M Print MDAT(NMDAT), continue TEXT.
* 8. $J As for $I, but with user format.
* 9. $G As for $F, but with user format.
* 10. $( Set a user format.
* 11. $T Tab.
* 12. Set when done with an action.
* 13. Set when done with boiler plate text for an error message.
* 0. Other Ignore the "$", continue with TEXT.
* KT Used for logic in output of headings.
* = 1 Output table headings.
* = 2 Get row/column widths for matrix output.
* = 3 Output column headings for matrix output.
* LASKNT In vector output value index for last element to print.
* LASTI Last index for matrix output, or for finding values that
* determine format.
* LBUF Position of characters in BUF, usually the last to print.
* LBUF1 Start of text to shift when shifting text in BUF to the left.
* LBUF2 End of text to shift when shifting text in BUF to the left.
* LENBUF Parameter giving the number of character in BUF.
* LENLIN Gives number of character in output lines.
* LENOUT Length of output for table or vector/matrix output.
* LENTXT Length of character array elements in TEXT.
* LENTRY Tells what to do on entry (and sometimes other places.)
* = 1 The value on first entry.
* = 2 A previous entry is to be continued.
* = 3 A non printing error message is to be continued
* = 4 Just done output from inside a METEXT action.
* = 5 Got "maximum" value for entries in a vector.
* = 6 Got "maximum" value for entries in a matrix.
* = 7 Vector (either print or get format for label indices.)
* = 8 Matrix (either print or get format for label indices.)
* = 9 Output of data in a table.
* =10 Get "maximum" valur for entries in a sparse vector.
* =11 Output a sparse vector.
* LHEAD If = 0 no print of DOLS, else DOLS printed in error messages.
* LINERR Gives LENLIN for error messages.
* LINMSG Gives LENLIN for diagnostic messages.
* LINSTR Space at start of line for label in vector and matrix output.
* Equivalenced to MAXWID(1).
* LNERR Parameter giving the default value for LENERR, only in XMESS.
* LNMSG Parameter giving the default value for LINMSG, only in XMESS.
* LOCBEG Index of first item in vector and matrix output.
* LPRINT For error messages with a print level .le. LPRINT nothing is
* printed (unless the message would result in a stop).
* LSTOP As for LPRINT, except with the stop level, and stopping.
* LSTRT Starting character position in BUF for storing next characters.
* LTEXT Length of heading text in TEXT.
* M Index for the current action.
* MACT Formal integer array specifying the actions, see above.
* MAXERR Value save in IVAR for user to get indication of last (really
* the maximum error seen so far = 1000 * (10*stop + print) + index. */
/* MAXWID Equivalenced to LINSTR and KOLWID.
* MBNDHI Upper bounds for inputs to IVAR.
* MBNDLO Lower bounds for inputs to IVAR.
* MDAT Array where user can store integers in IVAR for later output.
* Also used to store column indices when tables are saved on scratch
* unit.
*
* The following parameter names starting with ME define actions
* which the user can request. They have been documented in the
* description above, except for the ones defined just below.
* MEGBAS is 1 less than the smallest action that involves something
* other than just storing or retrieving a value.
* MEMAXI is the largest action which a user can request.
* MEVBAS is the smallest action index, used to set the starting index in
* IVAR.
* MEVLAS is the largest index for a variable in IVAR.
* MECONT, MEDDI, MEELI, MEEME, MEEUNI, MEFDAT, MEFMAT, MEFSPV,
* MEFVCI, MEFVEC, MEGBAS, MEGMAT, MEGVCI, MEGVEC, MEHEAD, MEIDAT,
* MEIMAT, MEIVCI, MEIVEC, MEJMAT, MEJVCI, MEJVEC, MEMAXE, MEMAXI,
* MEMDA1, MEMDA2, MEMDA3, MEMDA4, MEMDA5, MEMDAT, MEMLIN, MEMUNI,
* MENTXT, MEPRNT, MESCRN, MERES1, MERES2, MERES3, MERET, MESTOP,
* MESUNI, METAB, METDIG, METEXT
* MPT Current pointer to data for matrix or vector output.
* MTEXT Equivalenced to MTEXTR and MTEXTC.
* MTEXTC TEXT(MTEXTC) starts text for printing column labels.
* MTEXTR TEXT(MTEXTR) starts text for printing row labels.
* MUNIT Output unit used for messages that aren't in an error message.
* NCOL Number of columns for matrix output, 0 for vector output,
* count of column left for table output.
* NDIM Distance between columns for matrix output.
* NFDAT Index of next item in FDAT to print.
* NIDAT Index of next item in IDAT to print.
* NLINE Maximum number of data items to print on a line for matrix and
* vector output. If the scratch file is used for table output,
* NLINE gives the original end of the buffer.
* NMDAT Pointer to next thing to print from MDAT.
* NROCO Equivalenced to (NROW, NCOL). Used in matrix output.
* NROW Number of rows for matrix output. When printing tables,
* MDAT(NROW) gives place where line was split. (=0 if not split)
* NSKIP The amount to skip ahead on the next floating or integer
* output.
* NTEXT Index inside an element of TEXT for the next text output.
* NTEXTR Value of NTEXT to use if get a $R.
* NTXTSV Saved value of NTEXT when doing matrix output.
* OUNIT Index of the current output unit.
* SC Parameter for special character used to introduce actions.
* Default value is '$'. If this is changed the "$"'s in comments
* should be changed to the new value of the character. (Note that
* SC = '\' is not portable.)
* SCRNAM Name of file constructed for error output or message output.
* SUNIT Index for the scratch unit, -1 if not yet assigned.
* TEXT Formal argument giving the character string from which all text
* is taken.
* UMESS Name of subroutine called that does nothing, but which may be
* modified by the user to cause different actions to be taken.
* The usual version of MESS has the call to UMESS commented out.
* XARG If .true., output data is not integer, and a return is made to
* print data from FDAT.
* XARGOK Set .true. if call is from program that will print data from
* FDAT.
*
*++ CODE for .C. is active */
long int kc;
/*++ END */
/* ************** Parameters Defining Actions (See Above) ***************
* */
/* Parameters for changing the environment. */
/* Parameters for actions. */
/* Parameter derived from those above. */
/* ************************** Variable Declarations *********************
* */
/* ************************** Data from common block ********************
* */
/* ************************** End of stuff from common block ************
* */
/* 50 51, 52 53 54 55 56 57 58 */
/* ************************* Start of Executable Code *******************
*
* */
nskip = 0;
if (first)
{
first = FALSE;
/* Initialize common block */
cmessi.sunit = -1;
cmessi.lhead = 1;
cmessi.linmsg = LNMSG;
cmessi.linerr = LNERR;
cmessi.munit = 0;
cmessi.eunit = 0;
cmessi.kscrn = 0;
cmessi.maxerr = 0;
cmessi.tabspa = 6;
cmessi.lstop = 3;
cmessi.lprint = 3;
cmessi.errcnt = 0;
cmessi.ichar0 = '0';
cmessi.kdi = 1;
cmessi.kdj = 6;
cmessi.lenlin = LNMSG;
cmessi.lentry = 1;
cmessi.ounit = 0;
/*++ CODE for ~.C. is inactive
* DOLS(1:40) = '$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$'
* DOLS(41:72) ='$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$'
* FMTI = '(99I01)'
* FMTJ = '(99I06)'
* FMTG = '(1P,99Exx.xx) '
*++ CODE for .C. is active */
memset(cmessc.dols,'$',72);
strcpy( cmessc.fmti, "%*d " );
strcpy( cmessc.fmtj, "%*d\\0 " );
strcpy( cmessc.fmtg, "%*.*E\\0 " );
/*++ END */
}
else
{
/* 1 2 3 4 5 6 7 8 9 10 11 */
switch (cmessi.lentry)
{
case 1: goto L_5;
case 2: goto L_10;
case 3: goto L_20;
case 4: goto L_850;
case 5: goto L_1160;
case 6: goto L_1620;
case 7: goto L_1130;
case 8: goto L_1530;
case 9: goto L_960;
case 10: goto L_1210;
case 11: goto L_1220;
}
}
/* First entry for a message */
L_5:
cmessi.lbuf = 0;
/* Usual continuation entry */
L_10:
i = 1;
cmessi.ntext = 1;
cmessi.itext = 1;
cmessi.lentxt = (text_s - 1);
cmessi.nidat = 1;
cmessi.nfdat = 1;
cmessi.nmdat = 1;
goto L_120;
/* Continuation entry when have a non printing error
* Skip all actions -- Inside non-printing error message. */
L_20:
i = 1;
L_30:
k = Mact[i];
if (k <= MERET)
{
if (k == MERET)
goto L_120;
if (k == MECONT)
return;
if (k <= -MEGBAS)
goto L_180;
i += 2;
}
else
{
if (k > MEIMAT)
{
if (k > MEMAXI)
goto L_180;
k = MEIVEC + ((k - MEIVEC)%2);
}
i += incm[k-(MECONT)];
}
goto L_30;
/* Print BUF */
L_40:
messpr();
/* Usual place to end an action request. */
L_100:
i += incm[m-(MECONT)];
/* Pick up the next action request */
L_120:
m = Mact[i];
if (m > MEGBAS)
goto L_140;
i += 2;
if (labs( m ) > MEVLAS)
goto L_180;
if (m > 0)
{
ivar[m-(MEVBAS)] = Mact[i - 1];
if (ivar[m-(MEVBAS)] < mbndlo[m-(MEVBAS)])
{
ivar[m-(MEVBAS)] = mbndlo[m-(MEVBAS)];
}
else if (ivar[m-(MEVBAS)] > mbndhi[m-(MEVBAS)])
{
ivar[m-(MEVBAS)] = mbndhi[m-(MEVBAS)];
}
/* MEHEAD, MEDDIG, MEMLIN, MEELIN, MEMUNI, MEEUNI */
switch (m - MESUNI)
{
case 1: goto L_122;
case 2: goto L_124;
case 3: goto L_126;
case 4: goto L_126;
case 5: goto L_128;
case 6: goto L_128;
}
if (m != MENTXT)
goto L_120;
cmessi.itext = (cmessi.ntext - 1)/cmessi.lentxt;
cmessi.ntext += -cmessi.lentxt*cmessi.itext;
cmessi.itext += 1;
goto L_120;
L_122:
if (cmessi.lhead != 0)
{
}
goto L_120;
L_124:
cmessi.kdf = cmessi.kdfdef;
goto L_120;
L_126:
cmessi.lenlin = cmessi.linmsg;
goto L_120;
L_128:
if (ivar[m-(MEVBAS)] != 0)
{
k = labs(cmessi.ounit);
c_fname[m-15][6] = k / 10 + '0';
c_fname[m-15][7] = k % 10 + '0';
if (strcmp(&c_fname[16-m][6], &c_fname[m-15][6]))
c_handle[m-15] = fopen(c_fname[m-15],"w");
else
c_handle[m-15] = c_handle[16-m];
}
/* K = abs(IVAR(M)) */
cmessi.ounit = cmessi.munit;
goto L_120;
}
if (m == -MESUNI)
{
if (cmessi.sunit == -1L) {
scratch_file = tmpfile();
cmessi.sunit = 1L;}
}
/* if (SUNIT .le. 0) SUNIT = MESSGS()
* */
Mact[i - 1] = ivar[-m-(MEVBAS)];
goto L_120;
/* ME .. CONT RET EMES ETXT FSPV TABL */
L_140:
switch (m - MEGBAS)
{
case 1: goto L_170;
case 2: goto L_200;
case 3: goto L_310;
case 4: goto L_400;
case 5: goto L_1200;
case 6: goto L_910;
case 7: goto L_180;
}
if (m <= MEGVCI)
goto L_1000;
goto L_180;
/* Action MECONT -- Continue message on next entry */
L_170:
cmessi.lentry = 2;
return;
/* Some kind of error in message specification. */
L_180:
;
/*++ CODE for ~.C. is inactive
* BUF(1:57) =
* 1 'Actions in MESS terminated due to error in usage of MESS.'
*++ CODE for .C. is active */
memcpy(cmessc.buf,
"Actions in MESS terminated due to error in usage of MESS.",57);
cmessi.lbuf = 57;
/*++ END
*
* Action MERET -- Finish a message. */
L_200:
cmessi.lentry = 1;
j = inerr;
inerr = 0;
if (j >= 2)
inerr = -2;
if (j > 0)
goto L_330;
/* Finish print before exit. */
messpr();
return;
/* Action MEEMES -- Start an error message */
L_310:
cmessi.lentry = 3;
cmessi.errcnt += 1;
/*++ Code for UMESS is inactive
* call UMESS(TEXT, MACT(I+1), IVAR)
*++ End */
cmessi.imag = max( 0, min( 999, Mact[i + 2] ) );
k = Mact[i + 1];
cmessi.maxerr = max( cmessi.maxerr, 1000*k + cmessi.imag );
ks = k/10;
kp = k - 10*ks;
if (ks <= min( cmessi.lstop, 8 ))
{
if (kp <= cmessi.lprint)
{
inerr = -1;
goto L_20;
}
inerr = 1;
}
else
{
inerr = 2;
}
cmessi.ounit = cmessi.eunit;
cmessi.lenlin = cmessi.linerr;
/* Output a blank line. */
cmessc.buf[0] = ' ';
cmessi.lbuf = 1;
L_330:
messpr();
/* Put out line of $'s */
if (cmessi.lhead != 0)
{
cmessi.lbuf = min( (72), cmessi.lenlin );
/*++ CODE for ~.C. is inactive
* BUF(1:LBUF) = DOLS(1:LBUF)
* if (INERR.lt.0) BUF(5:37)=' Fatal error -- Program stopped. '
*++ CODE for .C. is active */
memcpy(cmessc.buf, cmessc.dols, cmessi.lbuf);
if (inerr < 0L)
memcpy(&cmessc.buf[4]," Fatal error -- Program stopped. ",34);
messpr();
/*++ END */
}
if (inerr <= 0)
{
/* Just finished an error message */
if (inerr != 0)
{
exit(0);
}
cmessi.ounit = cmessi.munit;
cmessi.lenlin = cmessi.linmsg;
return;
}
/* Just starting an error message get program name */
ntextr = 0;
goto L_410;
/* Got the program name in BUF. */
L_370:
cmessi.lbuf = min( cmessi.lbuf, 40 );
if (ks == 0)
{
ermsg1[16] = (kp + cmessi.ichar0);
memcpy(&cmessc.buf[cmessi.lbuf], ermsg1, strlen(ermsg1));
cmessi.lbuf += (27);
/* BUF(LBUF+1:LBUF+len(ERMSG1)) = ERMSG1 */
}
else
{
ermsg[29] = (ks + cmessi.ichar0);
ermsg[46] = (kp + cmessi.ichar0);
memcpy(&cmessc.buf[cmessi.lbuf], ermsg, strlen(ermsg));
cmessi.lbuf += (63);
/* BUF(LBUF+1:LBUF+len(ERMSG)) = ERMSG */
}
cmessi.lstrt = cmessi.lbuf + 1;
messfi();
cmessi.lbuf += cmessi.kdi;
sprintf(&cmessc.buf[cmessi.lstrt-1L], "%*ld",
(int)messcc.kciwid, cmessi.imag);
if (Mact[i + 3] < 0)
goto L_40;
/* write (BUF(LSTRT:LBUF), FMTI) IMAG
* Finish up the start error message action. */
if (Mact[i + 3] != 0)
{
cmessi.itext = (Mact[i + 3] - 1)/cmessi.lentxt;
cmessi.ntext = Mact[i + 3] - cmessi.lentxt*cmessi.itext;
cmessi.itext += 1;
}
cmessi.kspec = 13;
goto L_480;
/* Take care of any left over print from error header */
L_390:
if (cmessi.lbuf != 0)
messpr();
/* Action METEXT -- Print string from TEXT */
L_400:
cmessi.lentry = 4;
ntextr = cmessi.ntext;
itextr = cmessi.itext;
/* Continue with print from TEXT
* K take at most K-1 chars., but if 0 take max number
* K1 is last loc. used from TEXT if LENTXT is BIG.
* NEXT is first character location in TEXT(ITEXT)
* K2 is last character location in TEXT(ITEXT)
* LSTRT is first character position in BUF
* LBUF is last used character position in BUF */
L_410:
cmessi.lstrt = cmessi.lbuf + 1;
k2 = min( cmessi.lentxt, cmessi.ntext + (LENBUF - cmessi.lstrt) );
if ((ctmp=memchr(TEXT(cmessi.itext-1L,cmessi.ntext-1), SC,
k2 - cmessi.ntext + 1)) == NULL)
k = 0;
else
k = ctmp - TEXT(cmessi.itext-1L,cmessi.ntext-1) + 1;
if (k == 0)
{
/* K = index(TEXT(ITEXT)(NTEXT:K2), SC)
* Want to take all that we can. */
cmessi.lbuf = cmessi.lstrt + k2 - cmessi.ntext;
memcpy(&cmessc.buf[cmessi.lstrt-1L], TEXT(cmessi.itext-1L,
cmessi.ntext-1), k2 - cmessi.ntext + 1L);
if (k2 == cmessi.lentxt)
{
/* BUF(LSTRT:LBUF) = TEXT(ITEXT)(NTEXT:K2) */
cmessi.itext += 1;
cmessi.ntext = 1;
if (cmessi.lbuf <= cmessi.lenlin)
goto L_410;
}
else
{
cmessi.ntext = k2 + 1;
}
cmessi.kspec = 12;
if (cmessi.itext - itextr < 4000)
goto L_480;
cmessi.kspec = 2;
goto L_430;
}
cmessi.lbuf += k - 1;
if (k >= 2) memcpy(&cmessc.buf[cmessi.lstrt-1],
TEXT(cmessi.itext-1L, cmessi.ntext-1), k - 1L);
L_415:
;
/* if (K .ge. 2) BUF(LSTRT:LBUF) = TEXT(ITEXT)(NTEXT:NTEXT+K-2)
* Jump to location below if get $ after computing an NSKIP. */
cmessi.ntext += k + 1;
if (cmessi.ntext > cmessi.lentxt)
{
cmessi.itext += 1;
if (cmessi.ntext == cmessi.lentxt + 1)
{
c = TEXT(cmessi.itext - 2,0)[cmessi.lentxt - 1];
cmessi.ntext = 1;
}
else
{
c = TEXT(cmessi.itext - 1,0)[0];
cmessi.ntext = 2;
}
}
else
{
c = TEXT(cmessi.itext - 1,0)[cmessi.ntext - 2];
}
if (c == ' ')
{
/* Special code to take care of " " following "$". */
cmessi.ntext -= 1;
if (cmessi.ntext == 0)
{
cmessi.itext -= 1;
cmessi.ntext = cmessi.lentxt;
}
goto L_410;
}
if (ntextr == 0)
{
if (cmessi.lentry == 3)
goto L_370;
goto L_1510;
}
cmessi.kspec = istrstr( "BERNIMFJG(T", STR1(_c0,c) );
L_430:
if (cmessi.lbuf > cmessi.lenlin)
goto L_480;
/* 1 2 3 4 5 6 7 8 9 10 11 12, 13
* B E R N I M F J G ( T done end err */
switch (cmessi.kspec)
{
case 1: goto L_455;
case 2: goto L_480;
case 3: goto L_450;
case 4: goto L_460;
case 5: goto L_700;
case 6: goto L_680;
case 7: goto L_900;
case 8: goto L_700;
case 9: goto L_900;
case 10: goto L_600;
case 11: goto L_690;
case 12: goto L_410;
case 13: goto L_390;
}
/* No match -- Check for setting NSKIP */
if (((c >= '0') && (c <= '9')) || (c == '-'))
{
nskip = 0;
k1 = 1;
if (c != '-')
goto L_436;
k1 = -1;
L_433:
c = TEXT(cmessi.itext - 1,0)[cmessi.ntext - 1];
cmessi.ntext += 1;
if (cmessi.ntext >= cmessi.lentxt)
{
cmessi.itext += 1;
cmessi.ntext = 1;
}
L_436:
if ((c >= '0') && (c <= '9'))
{
nskip = 10*nskip + k1*(( c ) - cmessi.ichar0);
goto L_433;
}
if (c == '$')
{
k = 0;
goto L_415;
}
}
/* Continue with the text. */
L_440:
cmessi.lbuf += 1;
cmessc.buf[cmessi.lbuf - 1] = c;
goto L_410;
/* Reset NTEXT for $R */
L_450:
cmessi.ntext = ntextr;
cmessi.itext = itextr;
/* Done with METEXT action. */
L_455:
cmessi.nmdat = 1;
goto L_100;
/* At this point want to output all in BUF */
L_460:
for (cmessi.lbuf = cmessi.lbuf; cmessi.lbuf >= 1; cmessi.lbuf--)
{
if (cmessc.buf[cmessi.lbuf - 1] != ' ')
goto L_480;
}
L_480:
lbuf2 = cmessi.lbuf;
if (lbuf2 == 0)
{
cmessi.lbuf = 1;
cmessc.buf[0] = ' ';
}
else if (cmessi.lbuf > cmessi.lenlin)
{
for (k = cmessi.lenlin + 1; k >= (cmessi.lenlin/3); k--)
{
if (cmessc.buf[k - 1] == ' ')
{
cmessi.lbuf = k - 1;
goto L_490;
}
}
cmessi.lbuf = cmessi.lenlin;
}
L_490:
lbuf1 = cmessi.lbuf;
messpr();
if (lbuf1 >= lbuf2)
{
/* The entire buffer has been printed. */
if (cmessi.kspec <= 2)
goto L_455;
if (cmessi.kspec != 4)
goto L_430;
goto L_410;
}
/* Remove trailing blanks */
for (lbuf1 = lbuf1 + 1; lbuf1 <= lbuf2; lbuf1++)
{
if (cmessc.buf[lbuf1 - 1] != ' ')
goto L_520;
}
/* Shift the contents of the buffer. */
L_520:
cmessi.lbuf = lbuf2 - lbuf1 + 1;
cmessi.lstrt = 1;
L_530:
if (cmessi.lbuf >= lbuf1)
{
/* Take care of overlap. */
k = 2*lbuf1 - cmessi.lstrt;
memcpy(&cmessc.buf[cmessi.lstrt-1],&cmessc.buf[lbuf1-1],k-lbuf1);
cmessi.lstrt = lbuf1;
/* BUF(LSTRT:LBUF1-1) = BUF(LBUF1:K-1) */
lbuf1 = k;
goto L_530;
}
if (cmessi.lbuf>=cmessi.lstrt) memcpy(&cmessc.buf[cmessi.lstrt-1],
&cmessc.buf[lbuf1-1L], lbuf2-lbuf1+1);
goto L_430;
/* if (LBUF .ge. LSTRT) BUF(LSTRT:LBUF) = BUF(LBUF1:LBUF2)
*
* Get information on user format */
L_600:
cmessi.kspec = 8;
/* I, i, F, f, E, e, G, g */
switch (istrstr( "IiFfEeGg", STR1(_c0,TEXT(cmessi.itext - 1,0)[cmessi.ntext -
1]) ))
{
case 1: goto L_604;
case 2: goto L_604;
case 3: goto L_601;
case 4: goto L_601;
case 5: goto L_602;
case 6: goto L_602;
case 7: goto L_602;
case 8: goto L_602;
}
goto L_180;
L_601:
;
/*++ CODE for ~.C. is inactive
* FMTG='(0P,99F'
*++ CODE for .C. is active */
strcpy(cmessc.fmtg, "%*.*f\0");
messcc.lgprec = 0;
goto L_603;
/*++ END */
L_602:
;
/*++ CODE for ~.C. is inactive
* FMTG='(1P,99'//TEXT(ITEXT)(NTEXT:NTEXT)
*++ CODE for .C. is active */
strcpy(cmessc.fmtg, "%*.*E\0");
cmessc.fmtg[4] = TEXT(cmessi.itext - 1,0)[cmessi.ntext - 1];
messcc.lgprec = 0;
L_603:
cmessi.kspec = 9;
/*++ END */
L_604:
cmessi.imag = 0;
getw = TRUE;
k = cmessi.ntext;
strcpy( cmessc.fmtt, " " );
L_606:
;
cmessi.ntext += 1;
if (cmessi.ntext > cmessi.lentxt)
{
cmessi.itext += 1;
cmessi.ntext = 1;
}
/*++ CODE for ~.C. is inactive
* FMTT(NTEXT-K:NTEXT-K) = TEXT(ITEXT)(NTEXT:NTEXT)
*++ END */
jj = ( TEXT(cmessi.itext - 1,0)[cmessi.ntext - 1] ) - cmessi.ichar0;
if (getw)
{
if ((jj >= 0) && (jj <= 9))
{
cmessi.imag = 10*cmessi.imag + jj;
}
else
{
if (TEXT(cmessi.itext - 1,0)[cmessi.ntext - 1] == ')')
goto L_610;
if (TEXT(cmessi.itext - 1,0)[cmessi.ntext - 1] != '.')
goto L_180;
getw = FALSE;
}
}
else
{
if (TEXT(cmessi.itext - 1,0)[cmessi.ntext - 1] == ')')
goto L_610;
if ((jj < 0) || (jj > 9))
goto L_180;
/*++ CODE for .C. is active */
messcc.lgprec = 10*messcc.lgprec + jj;
}
/*++ END */
goto L_606;
L_610:
cmessi.ntext += 1;
if (cmessi.ntext > cmessi.lentxt)
{
cmessi.itext += 1;
cmessi.ntext = 1;
}
/*++ CODE for ~.C. is inactive
* if (KSPEC .eq. 8) then
* KDJ = IMAG
* FMTJ(5:7) = FMTT
* else
* IWG = IMAG
* FMTG(8:15) = FMTT
* end if
*++ CODE for .C. is active */
if (cmessi.kspec == 8)
cmessi.kdj = cmessi.imag;
else
cmessi.iwg = cmessi.imag;
if (TEXT(cmessi.itext - 1,0)[cmessi.ntext - 1] == SC)
goto L_410;
/*++ END */
if (cmessi.kspec == 8)
goto L_700;
if (cmessi.xargok)
return;
goto L_440;
/* Print from MDAT */
L_680:
iout = Mdat[cmessi.nmdat];
if (cmessi.nmdat >= 6)
{
Mdat[cmessi.nmdat] += 1;
}
else
{
cmessi.nmdat += 1;
}
goto L_720;
/* Process a tab */
L_690:
cmessi.lstrt = cmessi.lbuf + 1;
cmessi.lbuf = min( cmessi.lbuf + cmessi.tabspa - (cmessi.lbuf%
cmessi.tabspa), cmessi.lenlin + 1 );
for (kc=cmessi.lstrt-1; kc<cmessi.lbuf; kc++) cmessc.buf[kc]=' ';
goto L_850;
/* BUF(LSTRT:LBUF) = ' '
* Print from IDAT */
L_700:
cmessi.nidat += nskip;
nskip = 0;
iout = Idat[cmessi.nidat];
cmessi.nidat += 1;
L_720:
cmessi.lstrt = cmessi.lbuf + 1;
cmessi.imag = iout;
if (cmessi.kspec >= 8)
{
cmessi.lbuf += cmessi.kdj;
sprintf(&cmessc.buf[cmessi.lstrt-1],"%*ld",(int)cmessi.kdj, iout);
goto L_850;
/* write (BUF(LSTRT:LBUF), FMTJ) IOUT */
}
/* Get format for integer output. */
messfi();
cmessi.lbuf += cmessi.kdi;
sprintf(&cmessc.buf[cmessi.lstrt-1],"%*ld",(int)messcc.kciwid,iout);
L_850:
if (cmessi.lbuf <= cmessi.lenlin)
goto L_410;
/* write (BUF(LSTRT:LBUF), FMTI) IOUT
* Entry here to check line after numeric output. */
cmessi.kspec = 12;
goto L_480;
/* Take care of output for extra argument. */
L_900:
if (cmessi.xargok)
return;
goto L_180;
/* Action METABL -- Start a table */
L_910:
cmessi.gotfmt = Mact[i + 1] != 1;
if (!cmessi.gotfmt)
{
irow = 0;
*kolwid = 0;
}
cmessi.lentry = 9;
if (cmessi.lbuf != 0)
messpr();
L_920:
;
memset(cmessc.buf,' ',LENBUF);
cmessi.nrow = 1;
/* BUF = ' ' */
cmessi.ncol = Mact[i + 3];
icol = i + 3;
L_940:
icol += 1;
jj = Mact[icol];
cmessi.kline = jj%100;
cmessi.lenout = jj/100000;
cmessi.ncol -= max( cmessi.kline, 1 );
if (cmessi.gotfmt)
{
/* Print the data */
cmessi.lstrt = cmessi.lbuf + 1;
cmessi.lbuf = min( cmessi.lbuf + cmessi.kline*cmessi.lenout,
LENBUF );
jj /= 100;
kk = jj%10;
/* Text, I I', F E G */
switch (kk)
{
case 1: goto L_948;
case 2: goto L_941;
case 3: goto L_941;
case 4: goto L_943;
case 5: goto L_945;
case 6: goto L_944;
}
goto L_180;
/* Integer output */
L_941:
;
/*++ CODE for ~.C. is inactive
* KDI = LENOUT
* FMTI(5:5) = char(LENOUT / 10 + ichar0)
* FMTI(6:6) = char(mod(LENOUT, 10) + ichar0)
*++ END */
if (kk == 3)
{
sprintf(&cmessc.buf[cmessi.lstrt-1], "%*ld",
(int)cmessi.lenout, mact[i]);
goto L_960;
/* write (BUF(LSTRT:LBUF), FMTI) MACT(I+1) */
}
/* Regular integer output */
cmessi.nidat += nskip;
nskip = 0;
/*++ CODE for ~.C. is inactive
* write (BUF(LSTRT:LBUF), FMTI) (IDAT(K), K = NIDAT,
* 1 NIDAT+KLINE-1)
* NIDAT = NIDAT + KLINE
*++ CODE for .C. is active */
kk = cmessi.nidat;
for (cmessi.nidat=kk; cmessi.nidat<kk+cmessi.kline; cmessi.nidat++)
sprintf(&cmessc.buf[cmessi.lstrt+cmessi.lenout*(cmessi.nidat
- kk) - 1], "%*ld", (int)cmessi.lenout, idat[cmessi.nidat-1]);
goto L_960;
/*++ END
* Various floating point output */
L_943:
;
/*++ CODE for ~.C. is inactive
* FMTF = '(0P,99F . )'
*++ END */
goto L_946;
L_944:
;
/*++ CODE for ~.C. is inactive
* FMTF = '(1P,99G . )'
*++ END */
goto L_946;
L_945:
;
/*++ CODE for ~.C. is inactive
* FMTF = '(1P,99E . )'
*++ END */
L_946:
jj = (jj/10)%100;
/*++ CODE for ~.C. is inactive
* FMTF(8:8) = char(ICHAR0 + LENOUT / 10)
* FMTF(9:9) = char(ICHAR0 + mod(LENOUT, 10))
* FMTF(11:11) = char(ICHAR0 + JJ / 10)
* FMTF(12:12) = char(ICHAR0 + mod(JJ, 10))
*++ CODE for .C. is active */
strcpy(cmessc.fmtf, "%*.*E\0");
cmessi.iwf = cmessi.lenout;
messcc.lfprec = jj;
/*++ END */
if (!cmessi.xargok)
goto L_180;
cmessi.mpt = cmessi.nfdat;
cmessi.nfdat += cmessi.kline;
return;
/* Text output */
L_948:
k1 = cmessi.ntext + cmessi.lbuf - cmessi.lstrt;
memcpy(&cmessc.buf[cmessi.lstrt-1], TEXT(cmessi.itext-1,
cmessi.ntext -1), k1 - cmessi.ntext);
cmessi.ntext = k1;
/* BUF(LSTRT:LBUF) = TEXT(ITEXT)(NTEXT:K1-1) */
}
else
{
/* Print the heading */
cmessi.kt = 1;
messmh( text,text_s );
if (cmessi.kt < 0)
goto L_180;
}
L_960:
if ((cmessi.lbuf <= Mdat[cmessi.nrow]) && (cmessi.ncol > 0))
goto L_940;
if (cmessi.nrow == 1)
{
jj = cmessi.lbuf;
cmessi.lbuf = Mdat[1];
messpr();
cmessi.lbuf = jj;
}
else
{
if (irow == 0)
{
if (cmessi.nrow == 2)
{
/*++ CODE for ~.C. is inactive
* if (SUNIT .le. 0) SUNIT = MESSGS()
* rewind(SUNIT)
*++ CODE for .C. is active */
if (cmessi.sunit == -1) {
scratch_file = tmpfile();
cmessi.sunit = 1;}
rewind(scratch_file);
}
/*++ END */
}
fwrite(&cmessc.buf[4], cmessi.mdat[cmessi.nrow-1]-4, 1,
scratch_file);
}
/* write(SUNIT) BUF(5:MDAT(NROW)) */
if (cmessi.lbuf > Mdat[cmessi.nrow])
{
memcpy(&cmessc.buf[4], &cmessc.buf[cmessi.mdat[cmessi.nrow-1]],
cmessi.lbuf - cmessi.mdat[cmessi.nrow-1]);
cmessi.lbuf += -Mdat[cmessi.nrow] + 4;
/* BUF(5:LBUF - MDAT(NROW) + 4) = BUF(MDAT(NROW)+1:LBUF) */
cmessi.nrow += 1;
if (!cmessi.gotfmt)
{
if (cmessi.nrow > 5)
goto L_180;
Mdat[cmessi.nrow] = cmessi.lbuf;
}
if (cmessi.ncol == 0)
goto L_960;
goto L_940;
}
cmessi.lbuf = 0;
if (!cmessi.gotfmt)
{
cmessi.gotfmt = TRUE;
irow -= 1;
goto L_920;
}
Mact[i + 1] += 1;
if (Mact[i + 1] <= Mact[i + 2])
goto L_999;
Mact[i + 1] = 1;
if (cmessi.nrow == 1)
goto L_999;
fputc(EOF, scratch_file);
kk = 1;
/* endfile SUNIT */
L_994:
kk += 1;
if (kk > cmessi.nrow)
goto L_999;
rewind(scratch_file);
irow = -1;
/* rewind(SUNIT) */
k = kk;
L_995:
cmessi.lbuf = 5;
irow += 1;
if (irow != 0)
{
sprintf(cmessc.buf, "%4ld", irow%10000);
}
else
{
/* write(BUF(1:4), '(I4)') mod(IROW, 10000) */
memset(cmessc.buf,' ',4);
}
/* BUF(1:4) = ' ' */
for (j = 2; j <= k; j++)
{
if (j == k)
cmessi.lbuf = Mdat[kk];
if (fread(&cmessc.buf[4], cmessi.lbuf-4, 1,
scratch_file) == 0) goto L_994;
}
/* read(SUNIT, END = 994) BUF(5:LBUF) */
k = cmessi.nrow;
messpr();
goto L_995;
L_999:
cmessi.lentry = 1;
return;
/* Get started with vector or matrix output */
L_1000:
cmessi.inc = 1;
cmessi.locbeg = cmessi.nidat;
if (m > MEGMAT)
{
/* Have a user set increment between entries of a vector. */
m = MEIVEC + 2*(m - MEIVCI);
i += 1;
cmessi.inc = Mact[i];
}
cmessi.xarg = m > MEJMAT;
if (cmessi.xarg)
{
m -= 4;
cmessi.locbeg = cmessi.nfdat;
if (!cmessi.xargok)
goto L_40;
}
cmessi.gotfmt = m > MEIMAT;
if (cmessi.gotfmt)
m -= 2;
cmessi.locbeg += nskip;
nskip = 0;
cmessi.mpt = cmessi.locbeg;
if (m == MEIMAT)
goto L_1300;
/* Take care of setup for vector output */
knt = 0;
lasknt = Mact[i + 1];
if (lasknt <= 0)
{
lasknt = -lasknt;
knt = cmessi.locbeg - 1;
if (lasknt <= knt)
goto L_40;
}
cmessi.imag = lasknt;
cmessi.lasti = cmessi.locbeg + cmessi.inc*(lasknt - 1 - knt);
cmessi.ncol = 0;
/* Get format for label output. */
messfi();
messcc.kcrwid = messcc.kciwid;
kdilab = cmessi.kdi + 1;
/* FMTR = FMTI */
*linstr = 2*kdilab + 2;
if (cmessi.xarg)
{
if (!cmessi.gotfmt)
goto L_1150;
cmessi.iwf = cmessi.iwg;
f_strncpy( cmessc.fmtf, cmessc.fmtg, 20 );
/*++ CODE for .C. is active */
cmessi.iwf = cmessi.iwg;
messcc.lfprec = messcc.lgprec;
goto L_1160;
/*++ END */
}
messfd( idat );
/* After integer format */
cmessi.lenout = cmessi.kdi;
cmessi.nidat = cmessi.lasti + 1;
/* Common code continues here */
L_1080:
nline = (cmessi.lenlin - *linstr + 1)/cmessi.lenout;
if (cmessi.lbuf == 0)
goto L_1090;
k = max( *linstr, cmessi.lbuf + 1 );
if (((k - *linstr)/cmessi.lenout + (cmessi.lenlin - k + 1)/cmessi.lenout) <
nline)
k += cmessi.lenout - ((k - *linstr)%cmessi.lenout);
cmessi.kline = (cmessi.lenlin - k + 1)/cmessi.lenout;
if (cmessi.kline < min( lasknt - knt, nline/2 ))
goto L_1085;
*linstr = k - cmessi.lenout*((k - *linstr)/cmessi.lenout);
if (cmessi.kline >= lasknt - knt)
{
cmessi.kline = lasknt - knt;
k = cmessi.lbuf + 1;
}
knt += cmessi.kline;
for (kc=cmessi.lbuf; kc < k; kc++) cmessc.buf[kc] = ' ';
cmessi.lbuf = k;
/* BUF(LBUF+1:K) = ' ' */
goto L_1110;
L_1085:
messpr();
L_1090:
;
/*++ CODE for ~.C. is inactive
* BUF = ' '
* write (BUF(1:KDILAB), FMTR) KNT+1
*++ CODE for .C. is active */
memset(cmessc.buf,' ',LENBUF);
sprintf(cmessc.buf, "%*ld", (int)messcc.kcrwid, knt+1);
cmessc.buf[kdilab - 1] = '-';
/*++ END */
cmessi.kline = min( nline, lasknt - knt );
knt += cmessi.kline;
sprintf(&cmessc.buf[kdilab], "%*ld", (int)messcc.kcrwid, knt);
cmessc.buf[kdilab*2L-1] = ':';
for (kc=kdilab*2L; kc < *linstr-1; kc++) cmessc.buf[kc] = ' ';
cmessi.lbuf = *linstr;
/* write (BUF(KDILAB+1:2*KDILAB), FMTR) KNT
* BUF(2*KDILAB:LINSTR-1) = ':' */
L_1110:
cmessi.lstrt = cmessi.lbuf;
cmessi.lbuf += cmessi.lenout*cmessi.kline - 1;
if (cmessi.xarg)
return;
/* Integer output
*++ CODE for ~.C. is inactive
* write (BUF(LSTRT:LBUF), FMTI) (IDAT(K), K = MPT,
* 1 MPT+INC*(KLINE-1), INC)
*++ CODE for .C. is active */
for (k=cmessi.mpt; k<=cmessi.mpt+cmessi.kline-1; k++)
sprintf(&cmessc.buf[cmessi.lstrt+messcc.kciwid*(k-cmessi.mpt)-1],
"%*ld", (int)messcc.kciwid, idat[cmessi.inc*k-1]);
cmessi.mpt += cmessi.kline*cmessi.inc;
/*++ END
*
* Entry here after vector output. */
L_1130:
if (cmessi.mpt <= cmessi.lasti)
goto L_1085;
goto L_40;
/* Get other format */
L_1150:
cmessi.lentry = 5;
return;
/* After other format */
L_1160:
cmessi.lenout = cmessi.iwf;
cmessi.lentry = 7;
cmessi.nfdat = cmessi.lasti + 1;
goto L_1080;
/* Sparse vector output. */
L_1200:
cmessi.xarg = TRUE;
if (!cmessi.xargok)
goto L_40;
cmessi.gotfmt = FALSE;
cmessi.mpt = 1;
cmessi.locbeg = 1;
cmessi.inc = 1;
lasknt = Mact[i + 1];
cmessi.lasti = lasknt;
cmessi.lentry = 10;
return;
/* Entry after getting format for sparse data output. */
L_1210:
cmessi.lenout = cmessi.iwf;
cmessi.lentry = 11;
nline = cmessi.lenlin/cmessi.iwf;
L_1220:
messpr();
cmessi.kline = min( lasknt - cmessi.mpt + 1, nline );
if (cmessi.kline <= 0)
goto L_40;
cmessi.lbuf = cmessi.lenout*cmessi.kline;
return;
/* Take care of setup for matrix output */
L_1300:
;
cmessi.ndim = Mact[i + 1];
if (cmessi.ndim <= 0)
{
if (cmessi.ndim == 0)
goto L_40;
cmessi.inc = -cmessi.ndim;
cmessi.ndim = 1;
}
icol = 1;
irow1 = 1;
cmessi.nrow = Mact[i + 2];
if (cmessi.nrow <= 0)
{
if (cmessi.nrow == 0)
goto L_40;
irow1 = -cmessi.nrow/100000;
cmessi.nrow = -cmessi.nrow - 99999*irow1 - 1;
}
cmessi.ncol = Mact[i + 3];
if (cmessi.ncol <= 0)
{
if (cmessi.ncol == 0)
goto L_40;
icol = -cmessi.ncol/100000;
cmessi.ncol = -cmessi.ncol - 99999*irow1 - 1;
}
ntxtsv = cmessi.ntext;
itxtsv = cmessi.itext;
cmessi.irc = 1;
/* Compute widths for row and column labels */
L_1320:
Maxwid[cmessi.irc] = 0;
Mtext[cmessi.irc] = Mact[i + cmessi.irc + 3];
cmessi.imag = Nroco[cmessi.irc];
cmessi.kline = cmessi.imag;
L_1330:
cmessi.ntext = Mtext[cmessi.irc];
if (cmessi.ntext >= 0)
{
if (cmessi.ntext == 0)
{
cmessi.ltext = 5;
}
else
{
/* Go get row/column widths */
cmessi.kt = 2;
messmh( text,text_s );
if (cmessi.kt < 0)
{
Mtext[cmessi.irc] = 0;
goto L_1330;
}
}
messfi();
Maxwid[cmessi.irc] = max( Maxwid[cmessi.irc], cmessi.ltext +
cmessi.kdi + 1 );
if (cmessi.irc == 1)
messcc.kcrwid = cmessi.kdi;
else
messcc.kccwid = cmessi.kdi;
}
/* FMTIM(IRC) = FMTI */
cmessi.irc += 1;
if (cmessi.irc == 2)
goto L_1320;
/* Widths for Row and column titles have been computed. */
cmessi.kshift = 1;
cmessi.lasti = cmessi.locbeg + cmessi.inc*(cmessi.nrow - irow1);
if (cmessi.xarg)
{
if (!cmessi.gotfmt)
goto L_1610;
/*++ CODE for ~.C. is inactive
* IWF = IWG
* FMTF = FMTG
*++ CODE for .C. is active */
cmessi.iwf = cmessi.iwg;
messcc.lfprec = messcc.lgprec;
goto L_1620;
/*++ END */
}
messfd( idat );
if (cmessi.kdi >= *kolwid)
{
cmessi.lenout = cmessi.kdi;
}
else
{
cmessi.kshift = (*kolwid - cmessi.kdi + 2)/2;
cmessi.lenout = *kolwid;
/*++ CODE for ~.C. is inactive
* KDI = KOLWID
* FMTI(5:5) = char(ICHAR0 + KOLWID / 10)
* FMTI(6:6) = char(ICHAR0 + mod(KOLWID, 10))
*++ CODE for .C. is active */
messcc.kciwid = *kolwid;
}
/*++ END */
cmessi.nidat += cmessi.ndim*cmessi.ncol;
/* Continue with commmon code */
L_1390:
nline = (cmessi.lenlin - *linstr)/cmessi.lenout;
if (cmessi.lbuf <= *linstr)
goto L_1420;
L_1400:
messpr();
L_1420:
irow = irow1;
cmessi.kline = min( nline, cmessi.ncol - icol + 1 );
/* Output column labels (if any) */
if (*mtextc < 0)
goto L_1480;
cmessi.ntext = *mtextc;
cmessi.imag = icol;
cmessi.kt = 3;
messmh( text,text_s );
if (cmessi.kt < 0)
goto L_180;
/* Return from output of column labels. */
*mtextc = cmessi.ntext;
L_1480:
icol += cmessi.kline;
L_1490:
messpr();
/* Output row labels (if any) */
if (*mtextr < 0)
goto L_1520;
if (*mtextr == 0)
{
memcpy(&cmessc.buf[cmessi.lbuf],"Row ", 4);
cmessi.lbuf += 4;
/* BUF(LBUF+1:LBUF+4) = 'Row ' */
goto L_1515;
}
cmessi.ntext = *mtextr;
cmessi.itext = (cmessi.ntext - 1)/cmessi.lentxt;
cmessi.ntext += -cmessi.itext*cmessi.lentxt;
cmessi.itext += 1;
/* Go get text for row label */
ntextr = 0;
goto L_410;
/* Return from getting text for row label */
L_1510:
if (c != '#')
{
*mtextr = cmessi.ntext + cmessi.lentxt*(cmessi.itext - 1);
for (kc=cmessi.lbuf; kc < *linstr; kc++) cmessc.buf[kc] = ' ';
goto L_1520;
/* BUF(LBUF+1:LINSTR) = ' ' */
}
L_1515:
;
sprintf(&cmessc.buf[cmessi.lbuf],"%*ld",(int)messcc.kcrwid,irow);
for (kc=cmessi.lbuf+messcc.kcrwid;
kc < *linstr; kc++) cmessc.buf[kc] = ' ';
L_1520:
cmessi.lstrt = *linstr + 1;
/* write (BUF(LBUF+1:LINSTR), FMTR) IROW */
cmessi.lbuf = *linstr + cmessi.lenout*cmessi.kline;
cmessi.lasti = cmessi.mpt + cmessi.ndim*cmessi.kline - 1;
if (cmessi.xarg)
return;
/* Integer output */
for (k=cmessi.mpt; k<=cmessi.lasti; k+=cmessi.ndim)
sprintf(&cmessc.buf[cmessi.lstrt + messcc.kciwid*(k-cmessi.mpt)/
cmessi.ndim - 1], "%*ld", (int)messcc.kciwid, idat[k-1]);
L_1530:
cmessi.mpt += cmessi.inc;
/* write (BUF(LSTRT:LBUF), FMTI) (IDAT(K), K=MPT,LASTI,NDIM)
*
* Entry here after matrix output. */
irow += 1;
if (irow <= cmessi.nrow)
goto L_1490;
if (icol > cmessi.ncol)
{
cmessi.ntext = ntxtsv;
cmessi.itext = itxtsv;
goto L_40;
}
cmessi.mpt = cmessi.ndim*(icol - 1) + 1;
*mtextr = Mact[i + 4];
messpr();
cmessi.lbuf = 1;
cmessc.buf[0] = ' ';
goto L_1400;
/* Need to get format for matrix print. */
L_1610:
cmessi.lentry = 6;
return;
/* Entry after got format for matrix print */
L_1620:
if (cmessi.iwf >= *kolwid)
{
cmessi.lenout = cmessi.iwf;
}
else
{
cmessi.kshift = (*kolwid - cmessi.iwf + 2)/2;
cmessi.lenout = *kolwid;
cmessi.iwf = *kolwid;
strcpy(cmessc.fmtf, "%*.*E\0");
}
/* write (FMTF(7:8), '(I2)') KOLWID */
cmessi.nfdat += cmessi.ndim*cmessi.ncol;
cmessi.lentry = 8;
goto L_1390;
#undef TEXT
} /* end of function */
void /*FUNCTION*/ messfd(
long idat[])
{
long int _d_l, _d_m, _do0, _do1, imax, imin, j, k;
/* OFFSET Vectors w/subscript range: 1 to dimension */
long *const Idat = &idat[0] - 1;
/* end of OFFSET VECTORS */
/* Get the format for data to be printed in vectors and arrays.
*
* ************** Variable only used here *******************************
*
* K Temporary index.
* J Temporary index.
* IDAT Input array to MESS
* IMAX Used when computing largest integer in array.
* IMIN Used when computing smallest integer in array.
* */
/* For comments on other variables, see the listing for MESS. */
if (cmessi.gotfmt)
{
cmessi.kdi = cmessi.kdj;
messcc.kciwid = cmessi.kdj;
return;
/* FMTI = FMTJ */
}
k = 1;
imax = 1;
imin = 0;
L_10:
for (j = cmessi.locbeg, _do0=DOCNT(j,cmessi.lasti,_do1 = cmessi.inc); _do0 > 0; j += _do1, _do0--)
{
imax = max( imax, Idat[j] );
imin = min( imin, Idat[j] );
}
if (cmessi.ncol != 0)
{
k += 1;
cmessi.locbeg += cmessi.ndim;
cmessi.lasti += cmessi.ndim;
if (k <= cmessi.ncol)
goto L_10;
}
cmessi.imag = imax;
if ((cmessi.imag/10) + imin < 0)
cmessi.imag = imin;
cmessi.kdi = -cmessi.kdi;
messfi();
return;
} /* end of function */
void /*FUNCTION*/ messfi()
{
long int i, k, kd;
/* Get the format for the integer IMAG.
*
* ************** Variable only used here *******************************
*
* I, K, KD are used in determining number of characters needed to
* represent IMAG.
* */
/* For comments on other variables, see the listing for MESS. */
kd = 1;
if (cmessi.kdi < 0)
{
/* KDI < 0 to flag need for extra space -- avoids overflows */
cmessi.kdi = -cmessi.kdi;
kd = 2;
}
k = 1;
if (cmessi.imag < 0)
{
cmessi.imag = -cmessi.imag;
kd += 1;
}
i = cmessi.imag/10;
if (i != 0)
{
L_10:
k *= 10;
kd += 1;
if (i >= k)
goto L_10;
}
if (kd != cmessi.kdi)
{
cmessi.kdi = kd;
/*++ CODE for ~.C. is inactive
* FMTI(5:5) = char(ICHAR0 + KDI / 10)
* FMTI(6:6) = char(ICHAR0 + mod(KDI, 10))
*++ CODE for .C. is active */
messcc.kciwid = cmessi.kdi;
}
/*++ END */
return;
} /* end of function */
/*++ CODE for ~.C. is inactive
* integer function MESSGS()
*c Get a scratch unit assigned.
* integer J
*c
* MESSGS = 31
* 10 MESSGS = MESSGS - 1
* if (MESSGS .eq. 0) stop 'Could not assign scratch unit in MESS.'
* open (MESSGS, STATUS='SCRATCH', ACCESS='SEQUENTIAL',
* 1 FORM='UNFORMATTED', IOSTAT=J)
* if (J .ne. 0) go to 10
* return
* end
*++ END */
void /*FUNCTION*/ messmh(
char *text, int text_s)
{
#define TEXT(I_,J_) (text+(I_)*(text_s)+(J_))
byte c;
long int j, k, kb, kk, l, lstrdb, ltxtdb;
static long lflgdb = 2;
long int *const kolwid = (long*)((long*)cmessi.maxwid + 1);
long int *const linstr = (long*)cmessi.maxwid;
/* OFFSET Vectors w/subscript range: 1 to dimension */
long *const Maxwid = &cmessi.maxwid[0] - 1;
long *const Mdat = &cmessi.mdat[0] - 1;
/* end of OFFSET VECTORS */
/* Processing of multiple headings:
*
* J Used as a temporary index.
* K Used as a temporary index.
* KB Number of initial blanks
* KK Used as a temporary index.
* KT Used for logic in output of headings. Set <0 on exit if there
* is an input error.
* KT = 1 Output table headings. (Set to -1 on fatal error.)
* KT = 2 Get row/column widths for matrix output. (Set to -2 if
* error results in no headings.)
* KT = 3 Output column headings. (Set to -1 on fatal error.)
* L Used as a temporary index.
* LFLGDB 2 in usual case, 3 if see a "$ ".
* LSTRDB Value of LSTRT when see a "$ ".
* LTXTDB Value of LTEXT when see a "$ ".
* TEXT Original input character vector.
* */
/* For comments on other variables, see the listing for MESS. */
/*++ CODE for .C. is active */
long int kc;
/*++ END */
if (cmessi.ntext != 0)
{
cmessi.itext = (cmessi.ntext - 1)/cmessi.lentxt;
cmessi.ntext += -cmessi.itext*cmessi.lentxt;
cmessi.itext += 1;
}
for (j = 1; j <= max( 1, cmessi.kline ); j++)
{
if (cmessi.ntext == 0)
{
k = *kolwid;
goto L_210;
}
lflgdb = 2;
cmessi.ltext = 0;
L_110:
;
ctmp=memchr(TEXT(cmessi.itext-1L,cmessi.ntext-1), SC,
cmessi.lentxt - cmessi.ntext + 1);
if (ctmp == NULL)
l = 0;
else
l = ctmp - TEXT(cmessi.itext-1L,cmessi.ntext-1) + 1;
if (l == 0)
{
/* L = index(TEXT(ITEXT)(NTEXT:LENTXT), SC) */
cmessi.ltext += cmessi.lentxt - cmessi.ntext + 1;
if (cmessi.ltext < 80)
{
cmessi.itext += 1;
cmessi.ntext = 1;
goto L_110;
}
cmessi.ltext = 0;
if (cmessi.kt == 3)
goto L_310;
goto L_160;
}
cmessi.ntext += l + 1;
cmessi.ltext += l - 1;
if (cmessi.ntext > cmessi.lentxt)
{
cmessi.itext += 1;
if (cmessi.ntext == cmessi.lentxt + 1)
{
c = TEXT(cmessi.itext - 2,0)[cmessi.lentxt - 1];
cmessi.ntext = 1;
}
else
{
c = TEXT(cmessi.itext - 1,0)[0];
cmessi.ntext = 2;
}
}
else
{
c = TEXT(cmessi.itext - 1,0)[cmessi.ntext - 2];
}
if (c == 'H')
switch (cmessi.kt)
{
case 1: goto L_180;
case 2: goto L_190;
case 3: goto L_200;
}
if (c == 'E')
switch (cmessi.kt)
{
case 1: goto L_180;
case 2: goto L_310;
case 3: goto L_200;
}
if (c == '#')
switch (cmessi.kt)
{
case 1: goto L_140;
case 2: goto L_310;
case 3: goto L_200;
}
if (c == ' ')
{
/* Special code to set for removing the "$" preceding a blank. */
lstrdb = cmessi.lstrt;
lflgdb = 3;
ltxtdb = cmessi.ltext;
cmessi.ltext += 1;
goto L_110;
}
if (cmessi.kt != 1)
goto L_160;
L_140:
cmessi.ltext += 2;
goto L_110;
L_160:
cmessi.kt = -cmessi.kt;
goto L_310;
L_180:
*kolwid += cmessi.lenout;
if (cmessi.ltext == 0)
goto L_300;
kb = *kolwid - cmessi.ltext;
if (kb < 0)
{
puts( "Stopped in MESS -- Column width too small in a heading." );
exit(0);
}
if (cmessi.xarg)
kb = 1 + kb/2;
cmessi.lstrt = cmessi.lbuf + kb + 1;
cmessi.lbuf += *kolwid;
if (cmessi.lbuf <= cmessi.lenlin)
Mdat[cmessi.nrow] = cmessi.lbuf;
*kolwid = 0;
goto L_220;
/* Set up column widths */
L_190:
Maxwid[cmessi.irc] = max( Maxwid[cmessi.irc], cmessi.ltext );
goto L_300;
/* Output matrix column */
L_200:
k = *kolwid;
if (c != '#')
k = cmessi.ltext;
L_210:
kb = cmessi.lenout - *kolwid;
if (j == 1)
{
/* Special setup for the first column. */
if (cmessi.xarg)
kb = (kb + 1)/2;
kb += cmessi.kshift + *linstr - cmessi.lbuf;
}
kb += *kolwid - k;
cmessi.lstrt = cmessi.lbuf + kb + 1;
cmessi.lbuf = cmessi.lstrt + k - 1;
/* Set initial blanks */
L_220:
;
if (kb > 0) for (kc=cmessi.lstrt-kb-1; kc<cmessi.lstrt-1; kc++)
cmessc.buf[kc] = ' ';
if (cmessi.ntext == 0)
{
/* if (KB .gt. 0) BUF(LSTRT-KB:LSTRT-1) = ' '
* Move characters */
memcpy(&cmessc.buf[cmessi.lstrt-1],"Col ", 4);
c = '#';
/* BUF(LSTRT:LSTRT+3) = 'Col ' */
cmessi.lstrt += 4;
}
else
{
k = cmessi.ntext - cmessi.ltext - lflgdb;
if (k <= 0)
{
kk = max( 0, 3 - cmessi.ntext );
memcpy(&cmessc.buf[cmessi.lstrt-1L], TEXT(cmessi.itext-2L,
cmessi.lentxt+k-1), -k-kk+1L);
cmessi.lstrt += -k - kk + 1;
/* BUF(LSTRT:LSTRT-K-KK)=TEXT(ITEXT-1)(LENTXT+K:LENTXT-KK) */
k = 1;
}
if (cmessi.ntext > 3)
{
memcpy(&cmessc.buf[cmessi.lstrt-1L], TEXT(cmessi.itext-1L,
k-1), cmessi.ntext-k-2L);
cmessi.lstrt += cmessi.ntext - k - 2;
/* BUF(LSTRT:LSTRT+NTEXT-K-3) = TEXT(ITEXT)(K:NTEXT-3) */
}
}
if (lflgdb == 3)
{
/* Special code to remove the "$" preceding a blank. Only works for 1. */
for (l = lstrdb + ltxtdb + max( 0, kb ); l <= cmessi.lstrt; l++)
{
cmessc.buf[l - 1] = cmessc.buf[l];
}
lflgdb = 2;
cmessi.lstrt -= 1;
}
if (c == '#')
{
/* Output column index */
sprintf(&cmessc.buf[cmessi.lstrt-1], "%*ld ",
(int)(cmessi.lbuf-cmessi.lstrt), cmessi.imag+j-1);
if (cmessi.ntext != 0)
cmessi.ntext = k;
/* write (BUF(LSTRT:LBUF), FMTC) IMAG + J - 1 */
goto L_300;
}
/* Set trailing blanks */
if (cmessi.lstrt <= cmessi.lbuf)
for (kc=cmessi.lstrt-1; kc < cmessi.lbuf; kc++)
cmessc.buf[kc] = ' ';
L_300:
;
}
/* if (LSTRT .le. LBUF) BUF(LSTRT:LBUF) = ' ' */
L_310:
return;
#undef TEXT
} /* end of function */
void /*FUNCTION*/ messpr()
{
static long nscrn = 0;
/* Prints the buffer for MESS
*
* ************** Variable only used here *******************************
*
* NSCRN Number of lines currently on CRT from messages.
* */
/* For comments on other variables, see the listing for MESS. */
if (cmessi.lbuf != 0)
{
L_10:
if (cmessc.buf[cmessi.lbuf - 1] == ' ')
{
if (cmessi.lbuf > 1)
{
cmessi.lbuf -= 1;
goto L_10;
}
}
if (cmessi.ounit <= 0)
{
if (cmessi.kscrn > 0)
{
if (nscrn >= cmessi.kscrn)
{
printf(" Type 'Enter' to continue\n");
scanf( "%*[^\n]%*c" );
nscrn = 0;
/* print '('' Type "Enter" to continue'')'
* read (*, *) */
}
nscrn += 1;
}
printf("%.*s\n", (int)cmessi.lbuf, cmessc.buf);
if (cmessi.ounit == 0)
goto L_20;
/* print '(1X, A)', BUF(1:LBUF) */
}
/*++ CODE for ~.C. is inactive
* K = abs(OUNIT)
* write (K, '(A)', ERR=30) BUF(1:LBUF)
*++ CODE for .C. is active */
fprintf(c_handle[labs(cmessi.ounit)-1], "%.*s\n",
(int)cmessi.lbuf, cmessc.buf);
L_20:
cmessi.lbuf = 0;
/*++ END */
}
return;
/*++ CODE for ~.C. is inactive
*c See if opening fixes the error
*30 write(SCRNAM, '(A, I2.2, A)') 'MESSF_', K, '.tmp'
* open (UNIT=K, STATUS='UNKNOWN', FILE=SCRNAM)
* write (K, '(A)') BUF(1:LBUF)
* return
*++ END */
} /* end of function */
/* PARAMETER translations */
#define MEPRNT 21
/* end of PARAMETER translations */
void /*FUNCTION*/ messft(
long mact[],
char *ftext)
{
char text[1][3];
long int idat[1], j, k;
/* OFFSET Vectors w/subscript range: 1 to dimension */
long *const Idat = &idat[0] - 1;
long *const Mact = &mact[0] - 1;
/* end of OFFSET VECTORS */
/* Prints FTEXT, which contains a Fortran character string, and then
* call MESS to do the actions in MACT. Actions in MACT can not do
* anything other than actions that reference MACT.
* This routine intended for use by library subroutines getting text in
* the form of a Fortran character string.
* */
/*++ CODE for ~.C. is inactive
* character TEXT(1)*1
*++ CODE for .C. is active */
/*++ END */
for (j = 1; j <= 100; j += 2)
{
k = labs( Mact[j] );
if ((k > MEPRNT) || (k < MESUNI))
goto L_20;
}
L_20:
k = Mact[j];
Mact[j] = MECONT;
mess( mact, (char*)text,3, idat );
Mact[j] = k;
k = strlen(ftext);
cmessi.ntext = 1;
/* K = len(FTEXT) */
if (k != 0)
{
if (ftext[0] == '0')
{
cmessi.ntext = 2;
k -= 1;
if (cmessi.lbuf == 0)
{
cmessc.buf[0] = ' ';
cmessi.lbuf = 1;
}
}
messpr();
cmessi.lbuf = k;
memcpy(cmessc.buf, &ftext[cmessi.ntext-1], k);
}
/* BUF(1:K) = FTEXT(NTEXT:NTEXT+K-1) */
cmessi.ichar0 = '0';
if (Mact[j] != MECONT)
mess( &Mact[j], (char*)text,3, idat );
return;
} /* end of function */