aboutsummaryrefslogtreecommitdiff
path: root/pkg/utilities/nttools/tcreate/tcreate.x
diff options
context:
space:
mode:
Diffstat (limited to 'pkg/utilities/nttools/tcreate/tcreate.x')
-rw-r--r--pkg/utilities/nttools/tcreate/tcreate.x958
1 files changed, 958 insertions, 0 deletions
diff --git a/pkg/utilities/nttools/tcreate/tcreate.x b/pkg/utilities/nttools/tcreate/tcreate.x
new file mode 100644
index 00000000..6febb642
--- /dev/null
+++ b/pkg/utilities/nttools/tcreate/tcreate.x
@@ -0,0 +1,958 @@
+include <error.h> # for EA_ERROR
+include <time.h> # this defines SZ_TIME
+include <fset.h> # defines F_REDIR
+include <ctype.h> # defines IS_WHITE
+include <tbset.h>
+
+define SZ_LONG_LINE (8192+SZ_LINE) # allows input line up to 8192 char
+define SZ_FMT 17 # size of string containing print format
+define SZ_DTYPE 29 # size of string for data type
+define CPSPACE 21 # size of increment in space for col descr ptrs
+define T_MAXDIM 7 # maximum dimension for an array in a table
+
+# These three macros are for dim, the pointer to an array of pointers to
+# dimension info.
+# for column i:
+# dimension is TCR_NDIM (dim, i)
+# length of axis j is TCR_AXLEN (dim, i, j)
+define LEN_DIM_INFO T_MAXDIM + 1 # unit = SZ_INT32
+define TCR_NDIM Memi[Memi[$1+$2-1]] # dimension of array
+define TCR_AXLEN Memi[Memi[$1+$2-1]+$3] # length of an axis
+
+# tcreate -- Program to create a table from data in an ASCII file.
+#
+# Phil Hodge, 22-Jul-1987 Task created
+# Phil Hodge, 11-Aug-1987 Modify mk_new_cols for datatype=-n for char string.
+# Phil Hodge, 8-Sep-1987 Change name from tcreat.
+# Phil Hodge, 15-Oct-1987 Use tbcigi instead of COL_DTYPE.
+# Phil Hodge, 20-Sep-1988 Print warning if file does not exist.
+# Phil Hodge, 9-Mar-1989 Change data type in call to tbhanp from char to int.
+# Phil Hodge, 17-May-1989 Add history record to table giving creation date.
+# Phil Hodge, 22-May-1992 Allow input lines up to 1024 char; print warning
+# if entire line of data file is not read;
+# print prompt if input is STDIN and not redirected.
+# Phil Hodge, 11-Jan-1993 In mk_new_cols, move "ncols = ncols + 1" to just
+# before the call to tbcdef.
+# Phil Hodge, 10-May-1993 In row_copy, include TY_SHORT.
+# Phil Hodge, 11-Aug-1993 Add tcr_ctoi, which calls ctoi after skipping over
+# leading whitespace and/or a "+" sign; call in row_copy.
+# Phil Hodge, 18-Nov-1994 Add option of creating columns of arrays.
+# Phil Hodge, 19-Jul-1995 Add tp to calling sequence of tbcisa.
+# Phil Hodge, 20-Jul-1998 In cp_upar_tbl, call tbfres for a FITS table.
+# Phil Hodge, 18-Jun-1999 Add option to create a text table with explicit
+# column definitions.
+# Phil Hodge, 29-Jul-1999 In tcr_ctoi, check that the value in the data file
+# has no fractional part. linenum was added to the calling
+# sequence of tcr_ctoi for a possible error message.
+# Phil Hodge, 12-Nov-2001 Allow input lines up to 8192 characters in length.
+# Phil Hodge, 24-Dec-2003 Move the call to tbcisa from mk_new_cols to a
+# point after the call to tbtcre. This had to be done because
+# tbcisa sets the value of a header keyword, and the table file
+# doesn't exist until after tbtcre has been called. Add the
+# three routines dim_alloc, dim_set, and dim_free. Also change
+# the data type of cptr from TY_INT to TY_POINTER.
+# Phil Hodge, 20-Dec-2004 Check cdname, dname, pname for " ".
+
+procedure tcreate()
+
+pointer sp
+pointer tname # scratch for name of table to be created
+pointer cdname # scratch for name of file of column definitions
+pointer dname # scratch for name of file for table data
+pointer pname # scratch for name of file of header parameters
+pointer ttype # scratch for table type (e.g. "row")
+pointer tp # pointer to descriptor for output table
+pointer cptr # pointer to array of column pointers
+pointer dim # pointer to array of column dimension info
+int uparfd # fd for input file of header parameters
+int nskip # number of lines to skip at beg of data file
+int nlines # number of lines in file per row in table
+int npar # number of header parameters
+int nrows, ncols # number of rows and columns in table
+int extracol # number of extra columns to allocate
+int extrapar # extra space to allocate for header parameters
+int maxcols # size of arrays for column info
+bool histflag # add a history record with creation date?
+pointer tbtopn()
+int clgeti()
+bool clgetb()
+bool isblank()
+
+begin
+ call smark (sp)
+ call salloc (tname, SZ_FNAME, TY_CHAR)
+ call salloc (cdname, SZ_FNAME, TY_CHAR)
+ call salloc (dname, SZ_FNAME, TY_CHAR)
+ call salloc (pname, SZ_FNAME, TY_CHAR)
+ call salloc (ttype, SZ_FNAME, TY_CHAR)
+
+ call clgstr ("table", Memc[tname], SZ_FNAME)
+ call clgstr ("cdfile", Memc[cdname], SZ_FNAME)
+ call clgstr ("datafile", Memc[dname], SZ_FNAME)
+ call clgstr ("uparfile", Memc[pname], SZ_FNAME)
+ nskip = clgeti ("nskip")
+ nlines = clgeti ("nlines")
+ nrows = clgeti ("nrows")
+ histflag = clgetb ("hist")
+ extrapar = clgeti ("extrapar")
+ call clgstr ("tbltype", Memc[ttype], SZ_FNAME)
+
+ # The user might have given the name as " " instead of EOS (""); check
+ # for this, and in this case make sure the value is EOS to simplify
+ # checking elsewhere in this file.
+ if (isblank (Memc[cdname]))
+ Memc[cdname] = EOS
+ if (isblank (Memc[dname]))
+ Memc[dname] = EOS
+ if (isblank (Memc[pname]))
+ Memc[pname] = EOS
+
+ tp = tbtopn (Memc[tname], NEW_FILE, 0)
+
+ if (Memc[ttype] == 'r') { # row-ordered stsdas format
+ call tbpset (tp, TBL_WHTYPE, TBL_TYPE_S_ROW)
+ extracol = clgeti ("extracol")
+ } else if (Memc[ttype] == 'c') { # column-ordered stsdas format
+ if (nrows <= 0)
+ call error (1, "must specify nrows>0 for column-ordered table")
+ call tbpset (tp, TBL_WHTYPE, TBL_TYPE_S_COL)
+ call tbpset (tp, TBL_ALLROWS, nrows)
+ extracol = 0
+ } else if (Memc[ttype] == 't') { # text table
+ # not a simple text table, one with explicit column definitions
+ call tbpset (tp, TBL_WHTYPE, TBL_TYPE_TEXT)
+ call tbpset (tp, TBL_SUBTYPE, TBL_SUBTYPE_EXPLICIT)
+ } else { # default type
+ extracol = clgeti ("extracol")
+ }
+
+ # Read column descriptions, and create columns; ncols = 0 is OK.
+ call mk_new_cols (Memc[cdname], tp, cptr, dim, ncols, maxcols)
+
+ # Increase allocation of space for columns.
+ if (extracol > 0)
+ call tbpset (tp, TBL_INCR_ROWLEN, extracol)
+
+ # Open the (optional) file containing header parameters, and count how
+ # many there are. If npar = 0 the input file will not be left open.
+ if (Memc[pname] != EOS) {
+ call c_user_par (Memc[pname], uparfd, npar)
+ } else {
+ npar = 0 # there is no upar file
+ uparfd = NULL
+ }
+ if (histflag)
+ npar = npar + 1
+
+ # Specify how much space to allocate for header parameters.
+ call tbpset (tp, TBL_MAXPAR, npar+extrapar)
+
+ # Open (create) the table.
+ call tbtcre (tp)
+
+ # Assign column dimension info, if appropriate.
+ call dim_set (tp, Memi[cptr], dim, ncols)
+
+ # Copy header parameters to table, and close the uparfile.
+ call cp_upar_tbl (tp, uparfd, histflag)
+
+ # Read from data file and write to table.
+ if (ncols > 0)
+ call cp_dat_tbl (Memc[dname], tp, Memi[cptr], nskip, nlines, nrows)
+
+ call tbtclo (tp)
+ if (cptr != NULL)
+ call mfree (cptr, TY_POINTER)
+ call dim_free (dim, maxcols)
+
+ call sfree (sp)
+end
+
+
+# mk_new_cols -- make new columns
+# This routine reads column descriptions from an input ASCII file
+# and defines those columns in the table.
+
+procedure mk_new_cols (cdname, tp, cptr, dim, ncols, maxcols)
+
+char cdname[ARB] # i: name of column-definitions file
+pointer tp # i: pointer to table descriptor
+pointer cptr # o: pointer to array of column descriptors
+pointer dim # o: pointer to array of column dimension info
+int ncols # o: number of columns created (may be zero)
+int maxcols # o: size of arrays for column info
+#--
+pointer sp
+pointer lbuf # buffer for reading lines from col descr file
+char colname[SZ_COLNAME] # column name
+char colunits[SZ_COLUNITS] # column units
+char colfmt[SZ_COLFMT] # print format for column
+char chdtype[SZ_DTYPE] # column data type expressed as a char string
+int fd # for input ASCII file
+int linenum # line number counter (ignored)
+int datatype # column data type expressed as an int
+int nelem # array length
+int ip # index in line of text from input file
+int access(), open(), g_next_l(), ctowrd(), fstati()
+bool streq()
+
+begin
+ ncols = 0 # initial values
+ cptr = NULL
+ dim = NULL
+
+ if (cdname[1] == EOS) {
+ call eprintf ("No cdfile; an empty table will be created.\n")
+ return
+ } else if (access (cdname, 0, 0) == NO) {
+ call eprintf ("WARNING: can't read file %s;\n")
+ call pargstr (cdname)
+ call eprintf (" ... an empty table will be created.\n")
+ return
+ } else if (streq (cdname, "STDIN")) {
+ # Print a prompt if the input is not redirected.
+ if (fstati (STDIN, F_REDIR) == NO) {
+ call printf (
+ "Give column definitions (name, datatype, print format, units)\n")
+ call printf (" ... then newline & EOF to finish.\n")
+ call flush (STDOUT)
+ }
+ }
+
+ fd = open (cdname, READ_ONLY, TEXT_FILE)
+
+ call smark (sp)
+ call salloc (lbuf, SZ_LONG_LINE, TY_CHAR)
+
+ maxcols = CPSPACE
+ call calloc (cptr, maxcols, TY_POINTER)
+ call dim_alloc (dim, ncols, maxcols)
+
+ # While get next non-comment line ...
+ linenum = 0
+ while (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE, linenum) != EOF) {
+ ip = 1
+ if (ctowrd (Memc[lbuf], ip, colname, SZ_COLNAME) < 1)
+ call error (1, "could not read column name")
+ if (ncols+1 > maxcols) {
+ maxcols = maxcols + CPSPACE
+ call realloc (cptr, maxcols, TY_POINTER)
+ call dim_alloc (dim, ncols, maxcols)
+ }
+ if (ctowrd (Memc[lbuf], ip, chdtype, SZ_DTYPE) < 1) {
+ call strcpy ("r", chdtype, SZ_DTYPE) # default is real
+ colfmt[1] = EOS
+ colunits[1] = EOS
+ } else if (ctowrd (Memc[lbuf], ip, colfmt, SZ_COLFMT) < 1) {
+ colfmt[1] = EOS
+ colunits[1] = EOS
+ } else if (ctowrd (Memc[lbuf], ip, colunits, SZ_COLUNITS) < 1) {
+ colunits[1] = EOS
+ }
+
+ # Convert the format from Fortran style to SPP style.
+ call tbbftp (colfmt, colfmt)
+
+ iferr {
+ # Convert data type to an integer. Use ncols+1 because
+ # ncols hasn't been incremented yet.
+ call tcr_nelem (chdtype,
+ TCR_NDIM (dim, ncols+1), TCR_AXLEN (dim, ncols+1, 1),
+ T_MAXDIM, nelem, datatype)
+ } then {
+ call erract (EA_WARN)
+ call eprintf ("column `%s' ignored\n")
+ call pargstr (colname)
+ } else {
+ # Create the column.
+ ncols = ncols + 1 # bug fix 1/11/93
+ call tbcdef (tp, Memi[cptr+ncols-1],
+ colname, colunits, colfmt, datatype, nelem, 1)
+ }
+ }
+ call close (fd) # done with column descriptions file
+ call sfree (sp)
+end
+
+# Allocate or reallocate memory for the array of column dimensions.
+
+procedure dim_alloc (dim, ncols, maxcols)
+
+pointer dim # io: allocate (or reallocate) this buffer
+int ncols # i: current number of columns
+int maxcols # i: new number of elements for dim
+#--
+int i, k # loop indices
+
+begin
+ if (dim == NULL)
+ call malloc (dim, maxcols, TY_POINTER)
+ else
+ call realloc (dim, maxcols, TY_POINTER)
+
+ # Assign initial values. These may be updated later.
+ do i = ncols+1, maxcols { # zero indexed
+ call malloc (Memi[dim+i-1], LEN_DIM_INFO, TY_INT)
+ TCR_NDIM (dim, i) = 1
+ do k = 1, T_MAXDIM
+ TCR_AXLEN (dim, i, k) = 1
+ }
+end
+
+# For each column of multi-dimensional arrays, call the routine to assign
+# the keyword giving the length of each axis.
+
+procedure dim_set (tp, cp, dim, ncols)
+
+pointer tp # i: pointer to table descriptor
+pointer cp[ARB] # i: array of column descriptors
+pointer dim # i: pointer to array of column dimension info
+int ncols # i: current number of columns
+#--
+int i # loop index
+
+begin
+ do i = 1, ncols {
+ if (TCR_NDIM (dim, i) > 1)
+ call tbcisa (tp, cp[i], TCR_NDIM(dim,i), TCR_AXLEN(dim,i,1))
+ }
+end
+
+# Free memory for the array of column dimensions.
+
+procedure dim_free (dim, maxcols)
+
+pointer dim # io: pointer to array of column dimension info
+int maxcols # i: new number of elements for dim
+#--
+int i # loop index
+
+begin
+ if (dim == NULL)
+ return
+
+ do i = 1, maxcols { # zero indexed
+ if (Memi[dim+i-1] != NULL)
+ call mfree (Memi[dim+i-1], TY_INT)
+ }
+ call mfree (dim, TY_POINTER)
+end
+
+# c_user_par -- count header parameters
+# This routine opens an input ASCII file containing header parameters
+# and counts the number of such parameters. If the input file exists
+# and does contain parameters, the file will be left open; otherwise,
+# the input file will be closed, and both npar and uparfd will be set
+# to zero.
+# Blank and comment lines are ignored.
+
+procedure c_user_par (pname, uparfd, npar)
+
+char pname[ARB] # i: name of file of header parameters
+int uparfd # o: fd for input file of header parameters
+int npar # o: number of header parameters in file
+#--
+pointer sp
+pointer lbuf # scratch for input line buffer
+int linenum # line number counter (ignored)
+int access(), open(), g_next_l()
+
+begin
+ uparfd = NULL # initial values
+ npar = 0
+
+ if (pname[1] == EOS) {
+ return
+ } else if (access (pname, 0, 0) == NO) {
+ call eprintf ("WARNING: can't read file %s.\n")
+ call pargstr (pname)
+ return
+ }
+ uparfd = open (pname, READ_ONLY, TEXT_FILE)
+
+ call smark (sp)
+ call salloc (lbuf, SZ_LONG_LINE, TY_CHAR)
+
+ linenum = 0
+ while (g_next_l (uparfd, Memc[lbuf], SZ_LONG_LINE, linenum) != EOF)
+ npar = npar + 1
+
+ call sfree (sp)
+ if (npar <= 0) {
+ call close (uparfd)
+ uparfd = NULL
+ }
+end
+
+
+# cp_upar_tbl -- copy header parameters to table
+# This routine reads header parameters (keyword, type, value) from an
+# ASCII file and writes them to the table. The input file is then closed.
+# If uparfd is zero then it is assumed that the file does not exist.
+
+procedure cp_upar_tbl (tp, uparfd, histflag)
+
+pointer tp # i: pointer to table descriptor
+int uparfd # io: fd for file of header parameters
+bool histflag # i: add a history record with current date?
+#--
+pointer sp
+pointer lbuf # scratch for input line buffer
+pointer datetime # scratch for date and time
+pointer history # scratch for history record
+char keyword[SZ_KEYWORD] # keyword for parameter
+char chdtype[SZ_DTYPE] # column data type expressed as a char string
+long old_time, new_time # zero; current clock time
+int datatype # data type: TY_CHAR, etc
+int linenum # line number counter (ignored)
+int ip # counter for indexing in line buffer
+int parnum # parameter number (ignored)
+int tbltype # table type, to check for fits type
+int g_next_l(), ctowrd()
+int tbpsta(), tbfres()
+long clktime()
+
+begin
+ call smark (sp)
+ call salloc (lbuf, SZ_LONG_LINE, TY_CHAR)
+
+ tbltype = tbpsta (tp, TBL_WHTYPE)
+
+ # If there is a file of header parameters, read them and add to the
+ # table header.
+ if (uparfd != NULL) {
+
+ call seek (uparfd, BOF) # rewind to beginning of file
+ linenum = 0
+ while (g_next_l (uparfd, Memc[lbuf], SZ_LONG_LINE,
+ linenum) != EOF) {
+ ip = 1
+ # Read: keyword datatype value comment
+ if (ctowrd (Memc[lbuf], ip, keyword, SZ_KEYWORD) <= 0) {
+ call eprintf ("line is `%s'\n")
+ call pargstr (Memc[lbuf])
+ call error (1, "bad line in 'uparfile'")
+ }
+ if (tbltype == TBL_TYPE_FITS && tbfres (keyword) == YES)
+ next # skip reserved keywords if FITS table
+ if (ctowrd (Memc[lbuf], ip, chdtype, SZ_DTYPE) <= 0) {
+ call eprintf ("line is `%s'\n")
+ call pargstr (Memc[lbuf])
+ call error (1, "bad line in 'uparfile'")
+ }
+ call strlwr (chdtype)
+ datatype = chdtype[1]
+ switch (datatype) {
+ case 'r':
+ datatype = TY_REAL
+ case 'i':
+ datatype = TY_INT
+ case 'd':
+ datatype = TY_DOUBLE
+ case 'b':
+ datatype = TY_BOOL
+ default:
+ datatype = TY_CHAR
+ }
+ while (IS_WHITE(Memc[lbuf+ip-1]))
+ ip = ip + 1
+ call tbhanp (tp, keyword, datatype, Memc[lbuf+ip-1], parnum)
+ }
+ # Close the input ASCII file containing header parameters.
+ call close (uparfd)
+ }
+
+ if (histflag) {
+
+ call salloc (datetime, SZ_TIME, TY_CHAR)
+ call salloc (history, SZ_LINE, TY_CHAR)
+
+ old_time = 0
+ new_time = clktime (old_time)
+ call cnvtime (new_time, Memc[datetime], SZ_TIME)
+ call strcpy ("Created ", Memc[history], SZ_LINE)
+ call strcat (Memc[datetime], Memc[history], SZ_LINE)
+
+ call tbhadt (tp, "history", Memc[history])
+ }
+
+ call sfree (sp)
+end
+
+
+# cp_dat_tbl -- copy data to table
+# This routine reads from an ASCII data file and writes the values to
+# the table. A subroutine is called to do the actual copying for each row.
+
+procedure cp_dat_tbl (dname, tp, cptr, nskip, nlines, nrows)
+
+char dname[ARB] # i: name of file containing table data
+pointer tp # i: pointer to table descriptor
+pointer cptr[ARB] # i: array of pointers to column descriptors
+int nskip # i: number of lines to skip at beginning
+int nlines # i: number of lines per data file record
+int nrows # i: upper limit on number of rows (if > 0)
+#--
+pointer sp
+pointer linebuf # scratch for skipping header lines
+int fd # file descriptor for ASCII data file
+int rownum # row number
+int linenum # line number counter
+int k # loop index
+int stat
+bool done
+int access(), open(), getlline(), fstati()
+bool streq()
+
+begin
+ if (dname[1] == EOS) {
+ return
+ } else if (access (dname, 0, 0) == NO) {
+ call eprintf ("WARNING: file `%s' does not exist;\n")
+ call pargstr (dname)
+ call eprintf (" ... an empty table will be created.\n")
+ return
+ } else if (streq (dname, "STDIN")) {
+ # Print a prompt if the input is not redirected.
+ if (fstati (STDIN, F_REDIR) == NO) {
+ call printf (
+ "Give table data ... then newline & EOF to finish.\n")
+ call flush (STDOUT)
+ }
+ }
+ fd = open (dname, READ_ONLY, TEXT_FILE)
+
+ # Skip "header" lines.
+ if (nskip > 0) {
+ call smark (sp)
+ call salloc (linebuf, SZ_LONG_LINE, TY_CHAR)
+ do k = 1, nskip
+ stat = getlline (fd, Memc[linebuf], SZ_LONG_LINE)
+ call sfree (sp) # done with scratch space
+ }
+
+ # Read each record (which may be more than one line) from the
+ # data file, and write the values to the output row in the table.
+ rownum = 1
+ linenum = nskip # number of lines read so far
+ done = false
+ while ( !done ) {
+ call row_copy (tp, fd, cptr, rownum, nlines, linenum, done)
+ rownum = rownum + 1
+ if (nrows > 0 && rownum > nrows)
+ done = true
+ }
+ call close (fd)
+end
+
+
+
+# row_copy -- copy to a row of the table
+# This routine reads one or more records from data file and writes
+# a single row to the table.
+
+procedure row_copy (tp, fd, cptr, rownum, nlines, linenum, done)
+
+pointer tp # i: pointer to table descriptor
+pointer cptr[ARB] # i: array of pointers to column descriptors
+int fd # i: file descriptor for input data file
+int rownum # i: row number in table
+int nlines # i: number of lines per data file record
+int linenum # io: line number counter
+bool done # io: set to true when finished
+#--
+pointer sp
+pointer lbuf # buffer for reading from data file
+int ncols # number of columns in table
+int col # loop index (column number)
+int k # loop index for skipping lines
+int dtype # data type of a column (-n for char)
+int nelem # number of elements in array
+int i # loop index for element number
+int n # counter for number of lines per table row
+int ip # index in line buffer lbuf
+int nchar # number of char in text string
+int stat
+pointer str # buffer for value to be put in table
+double dval # "
+int ival # "
+bool bval
+int tbpsta(), tbcigi(), g_next_l(), tcr_ctoi(), ctod(), ctowrd()
+
+begin
+ call smark (sp)
+ call salloc (str, SZ_LINE, TY_CHAR)
+ call salloc (lbuf, SZ_LONG_LINE, TY_CHAR)
+
+ ncols = tbpsta (tp, TBL_NCOLS)
+
+ n = 1
+ if (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE, linenum) == EOF) {
+ done = true
+ return
+ }
+ ip = 1
+ for (col=1; col<=ncols; col=col+1) {
+ dtype = tbcigi (cptr[col], TBL_COL_DATATYPE)
+ nelem = tbcigi (cptr[col], TBL_COL_LENDATA)
+ switch (dtype) {
+ case TY_REAL,TY_DOUBLE:
+ do i = 1, nelem {
+ if (ctod (Memc[lbuf], ip, dval) < 1) {
+ if (nlines > 0 && n >= nlines)
+ return # ignore any remaining columns
+
+ # Print warning if we're not really at the end of line.
+ call tcr_check_eol (Memc[lbuf+ip-1], linenum)
+
+ if (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE,
+ linenum) == EOF) {
+ done = true
+ return
+ }
+ n = n + 1
+ ip = 1
+ if (ctod (Memc[lbuf], ip, dval) < 1) {
+ call sprintf (Memc[str], SZ_LINE,
+ "badly out of synch in line %d in data file\n")
+ call pargi (linenum)
+ call error (1, Memc[str])
+ }
+ }
+ call tbaptd (tp, cptr[col], rownum, dval, i, 1)
+ }
+
+ case TY_INT,TY_SHORT:
+ do i = 1, nelem {
+ if (tcr_ctoi (Memc[lbuf], ip, ival, linenum) < 1) {
+ if (nlines > 0 && n >= nlines)
+ return # ignore any remaining columns
+
+ call tcr_check_eol (Memc[lbuf+ip-1], linenum)
+
+ if (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE,
+ linenum) == EOF) {
+ done = true
+ return
+ }
+ n = n + 1
+ ip = 1
+ if (tcr_ctoi (Memc[lbuf], ip, ival, linenum) < 1) {
+ call sprintf (Memc[str], SZ_LINE,
+ "badly out of synch in line %d in data file\n")
+ call pargi (linenum)
+ call error (1, Memc[str])
+ }
+ }
+ call tbapti (tp, cptr[col], rownum, ival, i, 1)
+ }
+
+ case TY_BOOL:
+ do i = 1, nelem {
+ if (ctowrd (Memc[lbuf], ip, Memc[str], SZ_LINE) < 1) {
+ if (nlines > 0 && n >= nlines)
+ return # ignore any remaining columns
+
+ call tcr_check_eol (Memc[lbuf+ip-1], linenum)
+
+ if (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE,
+ linenum) == EOF) {
+ done = true
+ return
+ }
+ n = n + 1
+ ip = 1
+ if (ctowrd (Memc[lbuf], ip, Memc[str], SZ_LINE) < 1) {
+ call sprintf (Memc[str], SZ_LINE,
+ "badly out of synch in line %d in data file\n")
+ call pargi (linenum)
+ call error (1, Memc[str])
+ }
+ }
+ call strlwr (Memc[str])
+ if (Memc[str] == 'y' || Memc[str] == 't') # yes or true
+ bval = true
+ else if (Memc[str] == 'n' || Memc[str] == 'f') # no or false
+ bval = false
+ else {
+ call strcat (" is not a valid Boolean value",
+ Memc[str], SZ_LINE)
+ call error (1, Memc[str])
+ }
+ call tbaptb (tp, cptr[col], rownum, bval, i, 1)
+ }
+
+ default:
+ if (dtype >= 0)
+ call error (1, "invalid data type got past tbbtyp")
+
+ do i = 1, nelem {
+ # Be careful to distinguish between a value of "" at the
+ # end of a line and actually reaching the end of the line;
+ # ctowrd returns 0 in both cases. First skip whitespace.
+ while (IS_WHITE(Memc[lbuf+ip-1]))
+ ip = ip + 1
+ if (Memc[lbuf+ip-1] == '\n' || Memc[lbuf+ip-1] == EOS) {
+ if (nlines > 0 && n >= nlines)
+ return # ignore any remaining columns
+ if (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE,
+ linenum) == EOF) {
+ done = true
+ return
+ }
+ n = n + 1
+ ip = 1
+ }
+ nchar = ctowrd (Memc[lbuf], ip, Memc[str], SZ_LINE)
+ if (nchar > 0)
+ call tbaptt (tp, cptr[col], rownum,
+ Memc[str], nchar, i, 1)
+ }
+ }
+ }
+ # Skip extra lines if all columns gotten in fewer than nlines lines.
+ do k = n+1, nlines {
+ iferr (stat = g_next_l (fd, Memc[lbuf], SZ_LONG_LINE, linenum))
+ break
+ }
+
+ call sfree (sp)
+end
+
+# tcr_check_eol -- check for end of data
+# This routine checks whether the remainder of the line contains anything
+# other than whitespace and comments. If it does, a warning is printed.
+
+procedure tcr_check_eol (lbuf, linenum)
+
+char lbuf[ARB] # i: input line
+int linenum # i: line number for warning message
+#--
+int ip # loop index into lbuf
+bool line_empty # true if the line is empty
+bool done # loop termination flag
+
+begin
+ line_empty = false
+
+ ip = 1
+ done = false
+ while (!done) {
+ if (lbuf[ip] == ' ' || lbuf[ip] == '\t') { # skip whitespace
+ ip = ip + 1
+ } else if (lbuf[ip] == '\n' || lbuf[ip] == EOS) {
+ line_empty = true
+ done = true
+ } else if (lbuf[ip] == '#') {
+ line_empty = true
+ done = true
+ } else {
+ line_empty = false
+ done = true
+ }
+ }
+
+ if (!line_empty) {
+ call eprintf ("out of synch or extra data in line %d\n")
+ call pargi (linenum)
+ }
+end
+
+# tcr_nelem -- separate array length from data type
+# This routine takes a character string as input and returns the data
+# type, total array length, dimension of array, and length of each axis.
+# The syntax for axis lengths is numbers separated by commas, enclosed in
+# brackets or parentheses, following the data type. For example, a 3-D
+# array of 8-byte character strings with axis lengths of 30, 70, and 5
+# would be specified as ch*8[30,70,5]. The first axis is the most rapidly
+# varying (i.e. Fortran notation).
+#
+# The output data type is the usual integer code, e.g. TY_REAL, except
+# that for a character string of length N the code is -N. This is the
+# data type that would be given as input to tbcdef. The default data
+# type is real (TY_REAL).
+
+procedure tcr_nelem (chdtype, ndim, axlen, maxdim, nelem, dtype)
+
+char chdtype[ARB] # i: data type and dimensions
+int ndim # o: dimension of array
+int axlen[maxdim] # o: length of each axis of array
+int maxdim # i: size of array axlen
+int nelem # o: total number of elements in array
+int dtype # o: data type of column for input to tbcdef
+#--
+char temp[SZ_DTYPE] # scratch for copy of chdtype
+char lbracket # '['
+char lparen # '('
+char endchar # ']' or ')', as appropriate
+int indexb, indexp # locations of '[' and '(' in chdtype
+int ip, ctoi()
+int i, length # current dimension and axis length
+bool done # to stop loop over dimensions
+int stridx()
+string errmessage "data type `%s':\n"
+
+begin
+ lparen = '('
+ lbracket = '['
+
+ ndim = 1 # initial values
+ nelem = 1
+ do i = 1, maxdim
+ axlen[i] = 1
+
+ if (chdtype[1] == EOS) {
+ dtype = TY_REAL # default
+ return
+ }
+
+ call strcpy (chdtype, temp, SZ_DTYPE)
+ indexb = stridx (lbracket, chdtype) # "[" found?
+ indexp = stridx (lparen, chdtype) # "(" found?
+ done = false
+ if (indexb > 0 && indexp > 0) {
+ call eprintf (errmessage)
+ call pargstr (chdtype)
+ call error (1, "can't include both '[' and '('")
+ } else if (indexb > 0) {
+ endchar = ']'
+ ip = indexb
+ temp[ip] = EOS # now temp is just the data type
+ } else if (indexp > 0) {
+ endchar = ')'
+ ip = indexp
+ temp[ip] = EOS
+ } else {
+ done = true # don't try to extract array size
+ }
+
+ # Convert the string to integer code (e.g. "r" --> TY_REAL).
+ iferr {
+ call tbbtyp (temp, dtype)
+ } then {
+ call eprintf (errmessage)
+ call pargstr (chdtype)
+ call erract (EA_ERROR)
+ }
+
+ # Read axis lengths from brackets, if given.
+ i = 0
+ ip = ip + 1 # skip over '['
+ while (!done) {
+
+ if (ctoi (chdtype, ip, length) < 1) {
+ call eprintf (errmessage)
+ call pargstr (chdtype)
+ call error (1, "syntax error")
+
+ }
+
+ i = i + 1 # increment dimension
+ if (i > maxdim) {
+ call eprintf (errmessage)
+ call pargstr (chdtype)
+ call error (1, "dimension is too high")
+ }
+
+ if (length <= 0) {
+ call eprintf (errmessage)
+ call pargstr (chdtype)
+ call error (1, "axis lengths must be positive")
+ }
+
+ ndim = i
+ axlen[ndim] = length
+ nelem = nelem * length
+
+ if (chdtype[ip] == ',') { # separator between dimensions
+ ip = ip + 1
+ } else if (chdtype[ip] == endchar) { # ']' or ')'
+ done = true
+ } else if (chdtype[ip] == EOS) {
+ call eprintf (errmessage)
+ call pargstr (chdtype)
+ call eprintf ("info: missing `%c' assumed\n")
+ call pargc (endchar)
+ done = true
+ }
+ }
+end
+
+# tcr_ctoi -- ctoi, ignoring "+" sign
+# This calls ctoi after skipping over any whitespace and/or a plus sign.
+# Note that we allow whitespace after the sign as well as before. This
+# is reasonable because we know (from the cdfile) that we're getting an
+# integer rather than an arbitrary character string.
+#
+# After reading an integer value, if the next character in the input
+# string is not whitespace and not the end of the line, the word will be
+# reread from the input string as a double. If the value is actually
+# an integer, even though the string may contain a decimal point or an
+# exponent (e.g. "5." or "1.e2"), the integer will be returned as the
+# value of n. If the value has a fractional part, that's an error.
+
+int procedure tcr_ctoi (input, ip, n, linenum)
+
+char input[ARB] # i: input string
+int ip # io: starting/ending index in INPUT
+int n # o: value read from string
+int linenum # i: line number for possible error message
+#--
+pointer sp, word # in case value is floating point
+int i # local copy of integer value from string
+int nvals # value returned by ctoi
+bool positive # true if value is positive
+int ctoi(), ctod(), ctowrd()
+int ip_save # so we can call ctod() or ctowrd()
+double x
+
+begin
+ positive = true # initial value
+
+ while (IS_WHITE(input[ip])) # skip leading whitespace
+ ip = ip + 1
+
+ if (input[ip] == '+') # ignore "+" sign
+ ip = ip + 1
+
+ if (input[ip] == '-') { # make note of "-" sign
+ ip = ip + 1
+ positive = false
+ }
+
+ ip_save = ip
+
+ nvals = ctoi (input, ip, i)
+
+ # Allow for the possibility that the buffer contains a floating
+ # point value.
+ if (!IS_WHITE(input[ip]) && input[ip] != EOS) {
+
+ # Conversion to int was terminated before the end of the word.
+ ip = ip_save
+ nvals = ctod (input, ip, x)
+ if (nvals > 0) {
+ i = int (x)
+ if (x != double(i)) {
+ # There is a fractional part; this is an error.
+ call smark (sp)
+ call salloc (word, SZ_FNAME, TY_CHAR)
+ ip = ip_save
+ nvals = ctowrd (input, ip, Memc[word], SZ_FNAME)
+ call eprintf ("`%s' in line %d is not an integer\n")
+ call pargstr (Memc[word])
+ call pargi (linenum)
+ call error (1, "data type conflict with cdfile")
+ }
+ }
+ }
+
+ if (nvals < 1)
+ n = INDEFI
+ else if (positive)
+ n = i
+ else
+ n = -i
+
+ return (nvals)
+end
generated by cgit (git 2.34.1) at 2025-09-20 17:33:10 -0400