/*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 #include "fcrt.h" #include "mess.h" #include #include #include #include /*++ CODE for .C. is active */ static FILE *c_handle[2], *scratch_file; static char *c_fname[2]={"MESSF-xx", "MESSF-xx"}; char *ctmp; #include /* 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= 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 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 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 */