aboutsummaryrefslogtreecommitdiff
path: root/noao/digiphot/photcal/mkconfig/t_config.x
diff options
context:
space:
mode:
Diffstat (limited to 'noao/digiphot/photcal/mkconfig/t_config.x')
-rw-r--r--noao/digiphot/photcal/mkconfig/t_config.x1013
1 files changed, 1013 insertions, 0 deletions
diff --git a/noao/digiphot/photcal/mkconfig/t_config.x b/noao/digiphot/photcal/mkconfig/t_config.x
new file mode 100644
index 00000000..a3a19767
--- /dev/null
+++ b/noao/digiphot/photcal/mkconfig/t_config.x
@@ -0,0 +1,1013 @@
+include <ctype.h>
+include <fset.h>
+include <lexnum.h>
+
+# define some of the working space parameters
+
+define CFG_MAXLENEQN SZ_LINE # maximum length of an expression
+define CFG_MAXLENLINE 78 # maximum length of an output line
+define CFG_MAXLENTRANS 16000 # maximum length of transformation area
+define CFG_MAXLENPARAM 160 # maximum length of parameter area
+
+# define the internal help pages
+
+define CFG_CATHELP "photcal$mkconfig/catsection.key"
+define CFG_OBSHELP "photcal$mkconfig/obsection.key"
+define CFG_TRANSHELP "photcal$mkconfig/transection.key"
+
+# T_CONFIG -- Create the configuration file.
+
+procedure t_config()
+
+pointer output # pointer to the output configuration file
+pointer template # pointer to template configuration file
+pointer catalog # pointer to the template catalog section file
+pointer observation # pointer to the template observation section file
+pointer transform # pointer to the template transformation section file
+pointer deriv # pointer to the derivative syntax string
+int verify # verify each user entry
+
+int fd, cfd, ofd, tfd
+pointer sp
+bool clgetb()
+int access(), open(), btoi()
+
+begin
+ # Set the standard output to flush on a newline.
+ call fseti (STDOUT, F_FLUSHNL, YES)
+
+ # Allocate temporary space.
+ call smark (sp)
+ call salloc (output, SZ_FNAME, TY_CHAR)
+ call salloc (template, SZ_FNAME, TY_CHAR)
+ call salloc (catalog, SZ_FNAME, TY_CHAR)
+ call salloc (observation, SZ_FNAME, TY_CHAR)
+ call salloc (transform, SZ_FNAME, TY_CHAR)
+ call salloc (deriv, SZ_FNAME, TY_CHAR)
+
+ # Get the parameters.
+ call clgstr ("config", Memc[output], SZ_FNAME)
+ verify = btoi (clgetb ("verify"))
+
+ # Make the configuration file. If a template configuration file
+ # is supplied and exists then simply copy the template into the
+ # output configuration file. If no template is supplied begin
+ # prompting user for input. The user may supply a default
+ # catalog, observation or transformation section file in place of
+ # entering any given section by hand.
+
+ call clgstr ("template", Memc[template], SZ_FNAME)
+ if (access (Memc[template], 0, 0) == YES) {
+ call fcopy (Memc[template], Memc[output])
+ } else {
+
+ fd = open (Memc[output], NEW_FILE, TEXT_FILE)
+
+ call clgstr ("catalog", Memc[catalog], SZ_FNAME)
+ if (access (Memc[catalog], READ_ONLY, TEXT_FILE) == YES)
+ cfd = open (Memc[catalog], READ_ONLY, TEXT_FILE)
+ else
+ cfd = NULL
+ call clgstr ("observations", Memc[observation], SZ_FNAME)
+ if (access (Memc[observation], READ_ONLY, TEXT_FILE) == YES)
+ ofd = open (Memc[observation], READ_ONLY, TEXT_FILE)
+ else
+ ofd = NULL
+ call clgstr ("transform", Memc[transform], SZ_FNAME)
+ if (access (Memc[transform], READ_ONLY, TEXT_FILE) == YES)
+ tfd = open (Memc[transform], READ_ONLY, TEXT_FILE)
+ else
+ tfd = NULL
+
+ call ph_wconfig (fd, cfd, ofd, tfd, verify)
+
+ call close (fd)
+ if (cfd != NULL)
+ call close (cfd)
+ if (ofd != NULL)
+ call close (ofd)
+ if (tfd != NULL)
+ call close (tfd)
+ }
+
+ call sfree (sp)
+end
+
+
+# PH_WCONFIG -- Write the catalog, observation and transfromation section
+# of the configuration file by prompting the user. If the file descriptor
+# to the transformation file is not NULL then copy the template
+# transformation file into the tranformation section of the configuration
+# file.
+
+procedure ph_wconfig (fd, cfd, ofd, tfd, verify)
+
+int fd # the output configuration file descriptor
+int cfd # the input catalog file descriptor
+int ofd # the input observation file descriptor
+int tfd # the input transformation file descriptor
+int verify # verify each user entry
+
+begin
+ # Enter the catalog section.
+ if ((cfd != NULL) && (cfd != STDIN))
+ call fcopyo (cfd, fd)
+ else
+ call ph_rcsection (fd, "catalog", verify)
+
+ # Enter the observation section.
+ if ((ofd != NULL) && (ofd != STDIN))
+ call fcopyo (ofd, fd)
+ else
+ call ph_rosection (fd, "observation", verify)
+
+ # Enter the transformation section.
+ if ((tfd != NULL) && (tfd != STDIN))
+ call fcopyo (tfd, fd)
+ else
+ call ph_rtsection (fd, "transformation", verify)
+end
+
+
+# PH_RCSECTION -- Write the catalog section of the configuration file by
+# prompting the user.
+
+procedure ph_rcsection (fd, keyword, verify)
+
+int fd # file descriptor for the output configuration file
+char keyword[ARB] # keyword defining the configuration file section
+int verify # verify each user entry
+
+int stat, number, newnumber
+pointer sp, column, newcolumn
+int ph_rcolnumber()
+
+begin
+ # Allocate working space.
+ call smark (sp)
+ call salloc (column, SZ_LINE, TY_CHAR)
+ call salloc (newcolumn, SZ_LINE, TY_CHAR)
+
+ # Write the section title.
+ call fprintf (fd, "\n%s\n\n")
+ call pargstr (keyword)
+
+ # Scan the standard input.
+ call printf (
+ "\nENTER THE STANDARD STAR CATALOG FORMAT DESCRIPTION\n\n")
+ repeat {
+
+ # Read the column name and number.
+ stat = ph_rcolnumber (CFG_CATHELP, Memc[column], SZ_LINE, number)
+ if (stat == EOF)
+ break
+ if (stat <= 0)
+ next
+
+ # Verify and/or write the definition.
+ if (verify == NO) {
+
+ # Write the definition.
+ call fprintf (fd, "%s %d\n")
+ call pargstr (Memc[column])
+ call pargi (number)
+ next
+
+ } else {
+
+ call ph_vcolnumber (Memc[column], Memc[newcolumn], SZ_LINE,
+ number, newnumber)
+ call fprintf (fd, "%s %d\n")
+ call pargstr (Memc[newcolumn])
+ call pargi (newnumber)
+
+ }
+ }
+ call printf ("\n")
+
+ call sfree (sp)
+end
+
+
+# PH_ROSECTION -- Write the observation section of the configuration file by
+# prompting the user.
+
+procedure ph_rosection (fd, keyword, verify)
+
+int fd # file descriptor for the output configuration file
+char keyword[ARB] # keyword defining the configuration file section
+int verify # verify each user entry
+
+int stat, number, newnumber
+pointer sp, column, newcolumn
+int ph_rcolnumber()
+
+begin
+ call smark (sp)
+ call salloc (column, SZ_LINE, TY_CHAR)
+ call salloc (newcolumn, SZ_LINE, TY_CHAR)
+
+ # Write the section title.
+ call fprintf (fd, "\n%s\n\n")
+ call pargstr (keyword)
+
+ # Scan the standard input.
+ call printf ("\nENTER THE OBSERVATIONS FILE FORMAT DESCRIPTION\n\n")
+ repeat {
+
+ # Read the column name and number.
+ stat = ph_rcolnumber (CFG_OBSHELP, Memc[column], SZ_LINE, number)
+ if (stat == EOF)
+ break
+ if (stat <= 0)
+ next
+
+ # Verify and/or write the definition.
+ if (verify == NO) {
+
+ call fprintf (fd, "%s %d\n")
+ call pargstr (Memc[column])
+ call pargi (number)
+ next
+
+ } else {
+
+ call ph_vcolnumber (Memc[column], Memc[newcolumn], SZ_LINE,
+ number, newnumber)
+ call fprintf (fd, "%s %d\n")
+ call pargstr (Memc[newcolumn])
+ call pargi (newnumber)
+
+ }
+ }
+ call printf ("\n")
+
+ call sfree (sp)
+end
+
+
+# PH_RTSECTION -- Write the observation section of the configuration file by
+# prompting the user.
+
+procedure ph_rtsection (fd, keyword, verify)
+
+pointer fd # file descriptor for the output configuration file
+char keyword[ARB] # keyword defining the section
+int verify # verify each user entry
+
+int tfd, ffd, cfd, len_label, len_expr, len_dexpr
+int neq, nparam, stat
+pointer sp, label, param, str, expr, dexpr, trans, fit, const
+int ph_rlabel(), ph_rexpr(), ph_rlist(), stropen()
+
+begin
+ # Allocate temporary working space.
+ call smark (sp)
+ call salloc (label, SZ_LINE, TY_CHAR)
+ call salloc (param, SZ_LINE, TY_CHAR)
+ call salloc (str, SZ_LINE, TY_CHAR)
+ call salloc (expr, CFG_MAXLENEQN, TY_CHAR)
+ call salloc (dexpr, CFG_MAXLENEQN, TY_CHAR)
+
+ # Open the temporary string files.
+ call malloc (trans, CFG_MAXLENTRANS, TY_CHAR)
+ call malloc (fit, CFG_MAXLENPARAM, TY_CHAR)
+ call malloc (const, CFG_MAXLENTRANS, TY_CHAR)
+ tfd = stropen (Memc[trans], CFG_MAXLENTRANS, NEW_FILE)
+ ffd = stropen (Memc[fit], CFG_MAXLENPARAM, NEW_FILE)
+ cfd = stropen (Memc[const], CFG_MAXLENPARAM, NEW_FILE)
+
+ # Write the section title.
+ call fprintf (fd, "\n%s\n\n")
+ call pargstr (keyword)
+
+ call printf ("\nENTER THE TRANSFORMATION EQUATIONS\n")
+
+ # Scan the standard input.
+ neq = 0
+ repeat {
+
+ # Get the parameters for each equation.
+ call printf (
+ "\nEnter the label and functional form for EQUATION %d\n\n")
+ call pargi (neq + 1)
+
+ # Fetch and verify the equation label.
+ len_label = ph_rlabel ("label (e.g. VFIT)", Memc[label],
+ SZ_LINE, verify)
+ if (len_label == EOF)
+ break
+ if (len_label <= 0)
+ next
+
+ # Fetch and verify the transformation equation.
+ len_expr = ph_rexpr ("equation", Memc[expr], CFG_MAXLENEQN, neq + 1,
+ verify)
+ if (len_expr == EOF)
+ next
+ if (len_expr <= 0) {
+ call printf ("<Error> The function expression is blank\n")
+ next
+ }
+
+ # Write the equation to a temporary string file.
+ iferr {
+ call ph_wequation (tfd, Memc[label], len_label, Memc[expr],
+ len_expr)
+ } then
+ break
+
+ # Get the fitted parameters.
+ call printf ("\nEnter initial values for the ")
+ call printf ("parameters to be fit in EQUATION %d\n\n")
+ call pargi (neq + 1)
+ nparam = 1
+ len_dexpr = 1
+ repeat {
+ call sprintf (Memc[str], SZ_LINE, "%s %d")
+ call pargstr ("parameter")
+ call pargi (nparam)
+ stat = ph_rlist (Memc[dexpr], len_dexpr, CFG_MAXLENEQN,
+ Memc[str], verify)
+ if (stat == EOF)
+ break
+ if (stat <= 0) {
+ call printf ("\n")
+ call ph_wequation (STDOUT, Memc[label], len_label,
+ Memc[expr], len_expr)
+ call printf ("\n")
+ next
+ } else
+ nparam = nparam + 1
+ }
+
+ # Write the fitted parameters.
+ iferr {
+ if (nparam > 1)
+ call ph_wparam (ffd, "fit", 3, Memc[dexpr], len_dexpr - 3)
+ } then
+ break
+
+ # Get the constant parameters.
+ call printf ("\nEnter initial values for the ")
+ call printf ("parameters to be held constant in EQUATION %d\n\n")
+ call pargi (neq + 1)
+ nparam = 1
+ len_dexpr = 1
+ repeat {
+ call sprintf (Memc[str], SZ_LINE, "%s%d and value")
+ call pargstr ("parameter")
+ call pargi (nparam)
+ stat = ph_rlist (Memc[dexpr], len_dexpr, CFG_MAXLENEQN,
+ Memc[str], verify)
+ if (stat == EOF)
+ break
+ if (stat <= 0) {
+ call printf ("\n")
+ call ph_wequation (STDOUT, Memc[label], len_label,
+ Memc[expr], len_expr)
+ call printf ("\n")
+ next
+ } else
+ nparam = nparam + 1
+ }
+
+ # Write the constant parameters.
+ iferr {
+ if (nparam > 1)
+ call ph_wparam (cfd, "const", 5, Memc[dexpr], len_dexpr - 3)
+ } then
+ break
+
+ neq = neq + 1
+ }
+
+ call printf ("\n")
+
+ # Close the string files.
+ call strclose (tfd)
+ call strclose (ffd)
+ call strclose (cfd)
+
+ # Write output results to a file
+ call ph_wfile (fd, Memc[fit], CFG_MAXLENPARAM, Memc[const],
+ CFG_MAXLENPARAM, Memc[trans], CFG_MAXLENTRANS)
+
+ # Free memory.
+ call mfree (trans, TY_CHAR)
+ call mfree (fit, TY_CHAR)
+ call mfree (const, TY_CHAR)
+ call sfree (sp)
+end
+
+
+# PH_RCOLNUMBER -- Read in the column name and number as an identifier and
+# a number respectively.
+
+int procedure ph_rcolnumber (helpfile, column, max_lcolname, number)
+
+char helpfile[ARB] # name of the helpfile
+char column[ARB] # name of the column
+int max_lcolname # maximum length of the column name
+int number # column number
+
+bool streq(), ph_isident()
+int scan(), strmatch(), nscan()
+
+begin
+ # Issue the prompt.
+ call printf (
+ "Enter column definition (name number, ?=help, <EOF>=quit entry): ")
+ call flush (STDOUT)
+
+ if (scan () == EOF)
+ return (EOF)
+ call gargwrd (column, max_lcolname)
+ call gargi (number)
+
+ # Check for errors.
+ if (streq (column, "?")) {
+ call pagefile (helpfile, "")
+ return (0)
+ } else if (! ph_isident (column) && strmatch (column, "error(") == 0) {
+ call printf (
+ "<Error> %s is not a legal column name\n")
+ call pargstr (column)
+ return (0)
+ } else if (nscan() != 2) {
+ call printf ("<Error> Cannot decode the column number\n")
+ return (0)
+ } else if (number <= 1) {
+ call printf (
+ "<Error> Column 1 is reserved for the object name\n")
+ return (0)
+ }
+
+ return (nscan())
+end
+
+
+# PH_VCOLNUMBER -- Verify the column name and number.
+
+procedure ph_vcolnumber (column, newcolumn, max_lcolname, number, newnumber)
+
+char column[ARB] # input column name
+char newcolumn[ARB] # new column name
+int max_lcolname # maximum length of the column name
+int number # original column number
+int newnumber # new column number
+
+bool ph_isident()
+int scan(), nscan()
+
+begin
+ # Issue the verify prompt.
+ call printf ("\tVerify (%s %d) (name number, <CR>=ok): ")
+ call pargstr (column)
+ call pargi (number)
+ call flush (STDOUT)
+
+ # Get the new values.
+ if (scan () == EOF) {
+ newcolumn[1] = EOS
+ call printf ("\n")
+ call flush (STDOUT)
+ } else
+ call gargstr (newcolumn, max_lcolname)
+
+ # If the new input is not valid use the original values.
+ if (newcolumn[1] != EOS) {
+ call sscan (newcolumn)
+ call gargwrd (newcolumn, max_lcolname)
+ call gargi (newnumber)
+ if (! ph_isident(newcolumn))
+ call strcpy (column, newcolumn, max_lcolname)
+ if (nscan() != 2)
+ newnumber = number
+ else if (newnumber <= 1)
+ newnumber = number
+ } else {
+ call strcpy (column, newcolumn, max_lcolname)
+ newnumber = number
+ }
+end
+
+
+# PH_RLABEL -- Read a legal identifier or label.
+
+int procedure ph_rlabel (keyword, label, max_lenlabel, verify)
+
+char keyword[ARB] # the identfier or label keyword
+char label[ARB] # the output label
+int max_lenlabel # maximum length of the label
+int verify # verify the expression
+
+int len_label
+pointer sp, newlabel
+bool streq(), ph_isident()
+int scan(), strlen()
+
+begin
+ # Prompt for the label of the specified equation.
+ call printf ("Enter %s (label, ?=help, <EOF>=quit entry): ")
+ call pargstr (keyword)
+ call flush (STDOUT)
+
+ # Read the label value.
+ if (scan () == EOF) {
+ call printf ("\n")
+ return (EOF)
+ } else
+ call gargwrd (label, max_lenlabel)
+
+ # Check for errors.
+ if (streq (label, "?")) {
+ call pagefile (CFG_TRANSHELP, "")
+ return (0)
+ } else if (! ph_isident (label)) {
+ call printf ("<Error> %s is not a legal label\n")
+ call pargstr (label)
+ return (0)
+ } else {
+ len_label = strlen (label)
+ }
+
+ if (verify == NO)
+ return (len_label)
+
+ # Verify the label.
+ call smark (sp)
+ call salloc (newlabel, max_lenlabel, TY_CHAR)
+
+ # Issue the verify prompt.
+ call printf ("\tVerify (%s) (label, <CR>=ok): ")
+ call pargstr (label)
+ call flush (STDOUT)
+
+ # Read the new value. Restore the old values if the input is invalid.
+ if (scan () == EOF) {
+ Memc[newlabel] = EOS
+ call printf ("\n")
+ call flush (STDOUT)
+ } else
+ call gargwrd (Memc[newlabel], max_lenlabel)
+
+ # Check the value.
+ if (Memc[newlabel] != EOS) {
+ if (! ph_isident(Memc[newlabel]))
+ call strcpy (label, Memc[newlabel], max_lenlabel)
+ } else
+ call strcpy (label, Memc[newlabel], max_lenlabel)
+ len_label = strlen (Memc[newlabel])
+
+ call sfree (sp)
+
+ return (len_label)
+end
+
+
+# PH_REXPR -- Read in an expression. The expression can span multiple lines.
+
+int procedure ph_rexpr (keyword, expr, max_lenexpr, neq, verify)
+
+char keyword[ARB] # name of the expression
+char expr[ARB] # expression
+int max_lenexpr # the maximum length of an expression
+int neq # the equation number
+int verify # verify the expression
+
+int ip, op, len_expr, sz_expr
+pointer sp, newexpr
+bool streq()
+int strlen(), scan(), gstrcpy()
+
+begin
+ # Issue the prompt.
+ call printf ("Enter %s (equation, equation\=continue, ?=help, ")
+ call pargstr (keyword)
+ call printf ("<EOF>=quit entry):\n")
+
+ # Read in the expression.
+ ip = 1
+ repeat {
+
+ # Get a chunk of the equation.
+ if (scan () == EOF) {
+ call printf ("\n")
+ return (EOF)
+ } else
+ call gargstr (expr[ip], max_lenexpr)
+
+ # Decode the expresssion.
+ if (expr[ip] == EOS) {
+ break
+ } else if (streq (expr[ip], "?")) {
+ call pagefile (CFG_TRANSHELP, "")
+ call printf (
+ "Equation %d enter %s (?=help, \=continue, EOF=quit):\n")
+ call pargi (neq)
+ call pargstr (keyword)
+ next
+ } else {
+ ip = ip + strlen (expr[ip])
+ if (expr[ip-1] == '\\')
+ ip = ip - 1
+ else
+ break
+ }
+ }
+
+ # Return length of expression if verify is off.
+ len_expr = ip - 1
+ if (verify == NO)
+ return (len_expr)
+
+ # Allocate working space.
+ call smark (sp)
+ call salloc (newexpr, max_lenexpr, TY_CHAR)
+
+ # Issue the verify prompt.
+ call printf ("Verify (equation, <CR>=ok):\n")
+ call pargstr (keyword)
+
+ # Read the new values.
+ ip = 1
+ op = 1
+ while (ip <= len_expr) {
+
+ # Print a chunk of the existing equation.
+ sz_expr = min (len_expr - ip + 1, CFG_MAXLENLINE - 2)
+ call printf ("%*.*s\n")
+ call pargi (-sz_expr)
+ call pargi (sz_expr)
+ call pargstr (expr[ip])
+ call flush (STDOUT)
+
+ # Get a chunk of the new equation.
+ if (scan() == EOF) {
+ Memc[newexpr+op-1] = EOS
+ call printf ("\n")
+ call flush (STDOUT)
+ } else
+ call gargstr (Memc[newexpr+op-1], CFG_MAXLENLINE)
+
+ if (Memc[newexpr+op-1] == EOS) {
+ op = op + gstrcpy (expr[ip], Memc[newexpr+op-1], sz_expr)
+ #} else if (Memc[newexpr+op-1] == '\\') {
+ #if (scan() == EOF)
+ #Memc[newexpr+op-1] = EOS
+ #else
+ #call gargstr (Memc[newexpr+op-1], CFG_MAXLENLINE)
+ #op = op + strlen (Memc[newexpr+op-1])
+ } else
+ op = op + strlen (Memc[newexpr+op-1])
+
+ ip = ip + sz_expr
+ }
+
+ # Copy the new expression into the output buffer.
+ if (Memc[newexpr] != EOS)
+ call strcpy (Memc[newexpr], expr, max_lenexpr)
+
+ call sfree (sp)
+
+ return (op - 1)
+end
+
+
+# PH_RLIST -- Get a list of parameter = value strings.
+
+int procedure ph_rlist (list, op, max_lenlist, keyword, verify)
+
+char list[ARB] # list of parameter=value strings
+int op # pointer into the parameter list
+int max_lenlist # maximum length of parameter list
+char keyword[ARB] # prompt keyword
+int verify # verify the parameter values
+
+int stat
+pointer sp, param, number
+int ph_rpar(), gstrcpy()
+
+begin
+ # Allocate working space.
+ call smark (sp)
+ call salloc (param, SZ_LINE, TY_CHAR)
+ call salloc (number, SZ_LINE, TY_CHAR)
+
+ # Read the parameter and its associated value.
+ stat = ph_rpar (CFG_TRANSHELP, keyword, Memc[param], Memc[number],
+ SZ_LINE, verify)
+
+ # Copy the values into the fitted parameter string.
+ if (stat >= 2) {
+ op = op + gstrcpy (Memc[param], list[op], max_lenlist - op + 1)
+ op = op + gstrcpy (" = ", list[op], max_lenlist - op + 1)
+ op = op + gstrcpy (Memc[number], list[op], max_lenlist - op + 1)
+ op = op + gstrcpy (", ", list[op], max_lenlist - op + 1)
+ }
+
+ call sfree (sp)
+
+ return (stat)
+end
+
+
+# PH_RPAR -- Read in a user supplied parameter and value.
+
+int procedure ph_rpar (helpfile, keyword, param, number, max_lenparam,
+ verify)
+
+char helpfile[ARB] # name of the helpfile
+char keyword[ARB] # name of the keyword
+char param[ARB] # name of the parameter
+char number[ARB] # parameter value
+int max_lenparam # maximum length of parameter name and value
+int verify # verify the values
+
+int ip, nchars
+pointer sp, newparam, newnumber
+bool streq(), ph_isident()
+int scan(), nscan(), lexnum()
+
+begin
+ # Issue the prompt.
+ call printf (
+ "Enter %s (name value, ?=help, <EOF>=quit entry):")
+ call pargstr (keyword)
+ call flush (STDOUT)
+
+ # Read the values.
+ if (scan () == EOF) {
+ call printf ("\n")
+ return (EOF)
+ } else {
+ call gargwrd (param, max_lenparam)
+ call gargwrd (number, max_lenparam)
+ }
+
+ # Check for errors.
+ ip = 1
+ if (streq (param, "?")) {
+ call pagefile (helpfile, "")
+ return (0)
+ } else if (! ph_isident (param)) {
+ call printf ("<Error> %s is not a legal parameter name\n")
+ call pargstr (param)
+ return (0)
+ } else if (nscan() != 2) {
+ call printf ("<Error> Cannot decode the parameter value\n")
+ return (0)
+ } else if (lexnum (number, ip, nchars) == LEX_NONNUM) {
+ call printf (
+ "<Error> The parameter value %s is not a legal number\n")
+ call pargstr (number)
+ return (0)
+ } else if (verify == NO) {
+ return (nscan())
+ }
+
+ call smark (sp)
+ call salloc (newparam, max_lenparam, TY_CHAR)
+ call salloc (newnumber, max_lenparam, TY_CHAR)
+
+ # Issue the verify prompt.
+ call printf ("\tVerify (%s %s) (name value, <CR>=ok):")
+ call pargstr (param)
+ call pargstr (number)
+ call flush (STDOUT)
+
+ # Read the new values.
+ ip = 1
+ if (scan () == EOF)
+ Memc[newparam] = EOS
+ else
+ call gargstr (Memc[newparam], max_lenparam)
+
+ if (Memc[newparam] != EOS) {
+ call sscan (Memc[newparam])
+ call gargwrd (Memc[newparam], max_lenparam)
+ call gargwrd (Memc[newnumber], max_lenparam)
+ if (ph_isident (Memc[newparam]))
+ call strcpy (Memc[newparam], param, max_lenparam)
+ if ((nscan() == 2) && (lexnum (Memc[newnumber], ip, nchars) !=
+ LEX_NONNUM))
+ call strcpy (number, Memc[newnumber], max_lenparam)
+ }
+
+ call sfree (sp)
+
+ return (2)
+end
+
+
+# PH_WEQUATION -- Format and write a transformation equation to the
+# configuration file.
+
+procedure ph_wequation (fd, label, len_label, expr, len_expr)
+
+int fd # the output configuration file descriptor
+char label[ARB] # the equation label
+int len_label # length of the label
+char expr[ARB] # the left-hand side or function expression
+int len_expr # length of the function expression
+
+int op
+pointer sp, line
+errchk ph_write, putline
+
+begin
+ # Allocate working space.
+ call smark (sp)
+ call salloc (line, CFG_MAXLENLINE + 1, TY_CHAR)
+ op = 1
+
+ # Initialize the output buffer and copy the label, the colon
+ # character label delimiter, te function expression, the equal
+ # sign and the fit expression to the configurationf file.
+
+ call ph_write (fd, label, len_label, Memc[line], CFG_MAXLENLINE, op)
+ call ph_write (fd, " : ", 3, Memc[line], CFG_MAXLENLINE, op)
+ call ph_write (fd, expr, len_expr, Memc[line], CFG_MAXLENLINE, op)
+
+ # Flush the remainder of the output.
+ if (op > 1)
+ call putline (fd, Memc[line])
+
+ call sfree (sp)
+end
+
+
+# PH_WDERIV -- Write the derivative expression for the equation to the
+# output file.
+
+procedure ph_wderiv (fd, label, len_label, param, len_param, dexpr, len_dexpr)
+
+int fd # pointer to the output file descriptor
+char label[ARB] # the equation label
+int len_label # length of the label
+char param[ARB] # the derivative parameter name
+int len_param # length of the derivative parameter name
+char dexpr[ARB] # the derivative expression
+int len_dexpr # length of the derivative expression
+
+int op
+pointer sp, line
+errchk ph_write, putline
+
+begin
+ call smark (sp)
+ call salloc (line, CFG_MAXLENLINE + 1, TY_CHAR)
+ op = 1
+
+ # Copy the keyword and opening bracket, the equation label, the
+ # separating comma, the parameter name, the closing bracket and
+ # equal sign, and the derivative expression to the output file .
+
+ call ph_write (fd, "deriv (", 7, Memc[line], CFG_MAXLENLINE, op)
+ call ph_write (fd, label, len_label, Memc[line], CFG_MAXLENLINE, op)
+ call ph_write (fd, ",", 1, Memc[line], CFG_MAXLENLINE, op)
+ call ph_write (fd, param, len_param, Memc[line], CFG_MAXLENLINE, op)
+ call ph_write (fd, ") = ", 4, Memc[line], CFG_MAXLENLINE, op)
+ call ph_write (fd, dexpr, len_dexpr, Memc[line], CFG_MAXLENLINE, op)
+
+ # Flush the remainder of the output.
+ if (op > 1)
+ call putline (fd, Memc[line])
+
+ call sfree (sp)
+end
+
+
+# PH_WPARAM -- Write the fitted and constant parameters to the configuration
+# file.
+
+procedure ph_wparam (fd, keyword, len_keyword, paramlist, len_list)
+
+int fd # output file descriptor
+char keyword[ARB] # statement keyword
+int len_keyword # length of the keyword
+char paramlist[ARB] # fitted parameter list
+int len_list # length of fitted parameter list
+
+int op
+pointer sp, line
+errchk ph_write, putline
+
+begin
+ call smark (sp)
+ call salloc (line, CFG_MAXLENLINE + 1, TY_CHAR)
+
+ # Write the keyword, two blanks, and the parameter list.
+ op = 1
+ call ph_write (fd, keyword, len_keyword, Memc[line], CFG_MAXLENLINE, op)
+ call ph_write (fd, " ", 2, Memc[line], CFG_MAXLENLINE, op)
+ call ph_write (fd, paramlist, len_list, Memc[line], CFG_MAXLENLINE, op)
+
+ # Flush the remainder of the output.
+ if (op > 1)
+ call putline (fd, Memc[line])
+
+ call sfree (sp)
+end
+
+
+# PH_WFILE -- Write the stored strings files to the output file.
+
+procedure ph_wfile (fd, fit, max_lfit, const, max_lconst, trans, max_ltrans)
+
+int fd # the output file descriptor
+char fit[ARB] # the fitted parameter array
+int max_lfit # the maximum length of the fit array
+char const[ARB] # the constant parameter array
+int max_lconst # the maximum length of the constant array
+char trans[ARB] # the equation section
+int max_ltrans # the maximum length of the equation section
+
+int tfd, ffd, cfd
+pointer sp, line
+int stropen(), getline()
+
+begin
+ call smark (sp)
+ call salloc (line, SZ_LINE, TY_CHAR)
+
+ ffd = stropen (fit, max_lfit, READ_ONLY)
+ cfd = stropen (const, max_lconst, READ_ONLY)
+ tfd = stropen (trans, max_ltrans, READ_ONLY)
+
+ while (getline (ffd, Memc[line]) != EOF)
+ call putline (fd, Memc[line])
+ call putline (fd, "\n")
+ while (getline (cfd, Memc[line]) != EOF)
+ call putline (fd, Memc[line])
+ call putline (fd, "\n")
+ while (getline (tfd, Memc[line]) != EOF)
+ call putline (fd, Memc[line])
+
+ call strclose (tfd)
+ call strclose (ffd)
+ call strclose (cfd)
+
+ call sfree (sp)
+end
+
+
+# PH_WRITE -- Write an output record from the input stream.
+
+procedure ph_write (fd, input, max_linput, output, max_loutput, op)
+
+int fd # the output file descriptor
+char input[ARB] # the input array
+int max_linput # maximum length of the input array
+char output[ARB] # the output array
+int max_loutput # maximum length of the output array
+int op # the output array pointer
+
+int ip, nchars
+errchk putline
+
+begin
+ ip = 1
+
+ repeat {
+ nchars = min (max_linput - ip + 1, max_loutput - op + 1)
+ call amovc (input[ip], output[op], nchars)
+ ip = ip + nchars
+ op = op + nchars
+ if (op > max_loutput) {
+ output[op] = '\n'
+ output[op+1] = EOS
+ call putline (fd, output)
+ op = 1
+ }
+ } until (ip > max_linput)
+
+ output[op] = '\n'
+ output[op+1] = EOS
+end
+
+
+# PH_ISIDENT -- Check to see if a string is a legal identifier.
+
+bool procedure ph_isident (ident)
+
+char ident[ARB] # string to be tested
+
+bool isident
+int ip
+
+begin
+ if (ident[1] == EOS)
+ return (false)
+ if (! IS_ALPHA(ident[1]))
+ return (false)
+
+ isident = true
+ for (ip = 2; isident && (ident[ip] != EOS); ip = ip + 1) {
+ if ((! IS_ALPHA(ident[ip])) && (! IS_DIGIT(ident[ip])))
+ isident = false
+ }
+
+ return (isident)
+end
generated by cgit (git 2.34.1) at 2025-09-20 09:06:37 -0400