diff options
Diffstat (limited to 'pkg/utilities/nttools/stxtools')
76 files changed, 16328 insertions, 0 deletions
diff --git a/pkg/utilities/nttools/stxtools/changt.x b/pkg/utilities/nttools/stxtools/changt.x new file mode 100644 index 00000000..c3d4e511 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/changt.x @@ -0,0 +1,98 @@ +#--------------------------------------------------------------------------- +.help change_ext Jun93 xtools +.ih +NAME +change_ext -- Put the specified extension on a file name. +.ih +USAGE +call change_ext (in_name, newext, out_name, max_size) +.ih +ARGUMENTS +.ls in_name (I: char[ARB]) +The input pathname with which to change the arguments. +.le +.ls newext (I: char[ARB]) +The extension to replace the original extension with. +.le +.ls out_name (O: char[max_size]) +The resultant pathname with the new extension inserted. May be the +same as the in_name. +.le +.ls max_size (I: int) +The maximum length of the string out_name. +.le +.ih +DESCRIPTION +This routine replaces the old extension on a pathname with the new +extension specified in the argument "newext". Thus: + +.nf + dir$root.ext --> dir$root.newext +.fi +.ih +SEE ALSO +fparse +.endhelp +#--------------------------------------------------------------------------- +procedure change_ext (in_name, newext, out_name, max_size) + +char in_name[ARB] # I: Original input name. +char newext[ARB] # I: Extension to replace old one. +char out_name[max_size] # O: File name with new extension. +int max_size # I: Maximum size out_name. + +# Misc. +pointer dir # Directory part of pathname. +int index # Group index in pathname. +pointer ksection # Unparsable part of pathname. +int ngroup # Number of groups. +pointer root # Root part of pathname. +pointer section # Section part of pathname. +pointer sp # Stack pointer. +pointer sx # Generic string. + +begin + call smark (sp) + call salloc (dir, SZ_LINE, TY_CHAR) + call salloc (root, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + call salloc (ksection, SZ_LINE, TY_CHAR) + call salloc (sx, SZ_LINE, TY_CHAR) + + # Parse the file name COMPLETELY. + call fparse (in_name, Memc[dir], SZ_LINE, Memc[root], SZ_LINE, + Memc[sx], SZ_LINE, index, ngroup, + Memc[section], SZ_LINE, Memc[ksection], SZ_LINE) + + # Put directory and root together. + call strcpy (Memc[dir], out_name, max_size) + call strcat (Memc[root], out_name, max_size) + + # Change the extension. + call strcat (".", out_name, max_size) + call strcat (newext, out_name, max_size) + + # Handle group syntax. + if (index > 0) { + call sprintf (Memc[sx], SZ_LINE, "[%d") + call pargi (index) + call strcat (Memc[sx], out_name, max_size) + if (ngroup > 0) { + call sprintf (Memc[sx], SZ_LINE, "/%d") + call pargi (ngroup) + call strcat (Memc[sx], out_name, max_size) + } + call strcat ("]", out_name, max_size) + } + + # Append the "unparsable" parts. + call strcat (Memc[ksection], out_name, max_size) + + # Finally image sections. + call strcat (Memc[section], out_name, max_size) + + call sfree (sp) +end +#--------------------------------------------------------------------------- +# End of change_ext +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/checkdim.x b/pkg/utilities/nttools/stxtools/checkdim.x new file mode 100644 index 00000000..ef9ed017 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/checkdim.x @@ -0,0 +1,24 @@ +include <imhdr.h> + +#* HISTORY* +#* B.Simon 04-Mar-93 original + +# CHECKDIM -- Get the real dimension of an image + +int procedure checkdim (im) + +pointer im # i: image descriptor +#-- +int idim, jdim + +begin + # Ignore higher dimesions that only have length one + + jdim = 1 + do idim = 1, IM_NDIM(im) { + if (IM_LEN(im,idim) > 1) + jdim = idim + } + + return (jdim) +end diff --git a/pkg/utilities/nttools/stxtools/cif.h b/pkg/utilities/nttools/stxtools/cif.h new file mode 100644 index 00000000..55d87ab5 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/cif.h @@ -0,0 +1,95 @@ +#--------------------------------------------------------------------------- +.help cif.h Apr94 source +.ih +NAME +cif.h -- Definitions for the Coordinated Input File object. +.endhelp +#--------------------------------------------------------------------------- +#==== +# Below are the PUBLIC definitions of the CIF object. These may be +# used by any external application as desired. +#==== + +# Generic size of file names/character strings used by CIF. +define CIF_SZ_FNAME SZ_PATHNAME + +# Possible values for the operation code passed to the 'cif_next' routine. +define CIF_NEXT_GROUP 1 # Get next, if any groups +define CIF_NEXT_FILE 2 # Get next primary file + +# Status of the secondary files after a 'cif_next" call. +define CIF_OK 1 # New file which is accessable. +define CIF_NONE 2 # No accessable file found. +define CIF_SAME 3 # File name is the same as previous. +define CIF_EXISTS 4 # Output file exists. + +# CIF structure variables: Primary file +define CIF_p_file_list CIF_file_list(CIF_p($1)) +define CIF_p_file CIF_file(CIF_p($1)) +define CIF_p_ext CIF_ext(CIF_p($1)) +define CIF_p_status CIF_status(CIF_p($1)) +define CIF_p_nloop CIF_nloop(CIF_p($1)) + +# CIF structure variables: Input Files +define CIF_in_file_list CIF_file_list(CIF_in($1,$2)) +define CIF_in_file CIF_file(CIF_in($1,$2)) +define CIF_in_ext CIF_ext(CIF_in($1,$2)) +define CIF_in_status CIF_status(CIF_in($1,$2)) +define CIF_in_nloop CIF_nloop(CIF_in($1,$2)) + +# CIF structure variables: Output Files. +define CIF_out_file_list CIF_file_list(CIF_out($1,$2)) +define CIF_out_file CIF_file(CIF_out($1,$2)) +define CIF_out_ext CIF_ext(CIF_out($1,$2)) +define CIF_out_status CIF_status(CIF_out($1,$2)) + +#=========================================================================== +#=========================================================================== +# The Private definitions to be used by the object code alone. Any use +# of the below macros constitutes an interface violation. +#=========================================================================== + +# Type of file which the current file name represents. +define CIF_GENERIC 1 +define CIF_IMAGE 2 +define CIF_DIRECTORY 3 +define CIF_SAME_ROOT 4 + +#==== +# The CIF object structure. +#==== +define CIF_p Memi[$1] +define CIF_in_ptr Memi[$1+1] +define CIF_n_in Memi[$1+2] +define CIF_out_ptr Memi[$1+3] +define CIF_n_out Memi[$1+4] +define CIF_loop Memi[$1+5] +define CIF_SZ 6 + +define CIF_in Memi[CIF_in_ptr($1)+$2-1] +define CIF_out Memi[CIF_out_ptr($1)+$2-1] + +#==== +# CIF File Object Structure +#==== +define CIF_list Memi[$1] +define CIF_group Memi[$1+1] +define CIF_status Memi[$1+2] +define CIF_nloop Memi[$1+3] +define CIF_cg Memi[$1+5] +define CIF_type Memi[$1+6] +define CIF_cbuf Memi[$1+7] +define CIF_SZ_FILE 8 + +define CIF_file_list Memc[CIF_cbuf($1)] +define CIF_file Memc[CIF_cbuf($1)+CIF_SZ_FNAME+1] +define CIF_ext Memc[CIF_cbuf($1)+2*(CIF_SZ_FNAME+1)] +define CIF_base Memc[CIF_cbuf($1)+3*(CIF_SZ_FNAME+1)] +define CIF_SZ_FILE_CBUF 4*(CIF_SZ_FNAME+1) + +# Indexed versions of some strings. +define CIF_basei Memc[CIF_CBUF($1)+3*(CIF_SZ_FNAME+1)+$2-1] + +#--------------------------------------------------------------------------- +# End of cif.h +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/cif.x b/pkg/utilities/nttools/stxtools/cif.x new file mode 100644 index 00000000..6fa3a7f2 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/cif.x @@ -0,0 +1,806 @@ +include <imhdr.h> +include "cif.h" + +#--------------------------------------------------------------------------- +.help cif Apr94 source +.ih +NAME +cif -- Coordinated Input File object +.ih +DESCRIPTION +The Coordinated Input File (CIF) object manages multiple input/output +files that are keyed on a single input file list. This is useful for +tasks whose input data may come from several different types of input +files. These input files are coordinated, or linked with, some +primary input file. This object also handles the creation of output +files, again linked in some way with the primary input file list. + +An explanation of the problem for which this interface was developed +should help demonstrate the point of the CIF object. For GHRS, the +calibrated output products includes a flux file, indicated by a file +extension of C1H, and a wavelength vector file, indicated by a file +extension of C0H. The number of groups in each file is the same, with +each group of the wavelength file corresponding to each group of the +flux file. The primary input file list would be the flux files and +the one of the secondary input files would be the rootname of the flux +file but with the C0H extension. The CIF object ensures that the +files are opened "in lock step". As output, there probably is only +one output list, each file with the same number of groups as the +primary input file, but with a new extension, some addition to the +rootname, or placed in another directory with the same root/extension. + +The following sections discuss the public and private +interfaces. +.ih +PUBLIC INTERFACE +The public interface to CIF consists of three subroutines and a number +of variables. The subroutines are: + +.nf + cif_alloc + cif_next + cif_free +.fi + +Detailed description of the subroutines are: + +.ls pointer = cif_alloc (n_in, n_out) +This routine creates the CIF object. It requires the number of input +files and output files that will be coordinated with the primary input +file. Note, the primary input file is NOT counted as one of the +inputs. The CIF variables are initialized to default or undefined +values. +.ls n_in (int) +Number of input files that will be coordinated. 0 if no input files +are required. +.le +.ls n_out (int) +Number of output files that will be coordinated. 0 if no output files +are requierd. +.le +.ls RETURNS (pointer) +Pointer to the CIF object. This pointer will be used in other +subroutine calls and accessing the CIF object variables. +.le +.le +.ls boolean = cif_next (o, type) +This is the main loop call for the CIF object. The CIF variables are +populated with the next set of file names. This can either be the +next groups of files, or a new set of files depending on the type +specified. If the value of cif_next is TRUE, then there are more +files. If FALSE, the end of the list has been reached, i.e. there are +no more primary files to be had. On return, the CIF variables *_file +and *_status are set. See the description below of the CIF +variables for more information. +.ls o (pointer) +The pointer to a CIF object created with cif_alloc. +.le +.ls type (int) +What "type" to get next. Possible values are +.nf + CIF_FILE - Get next primary file and associated + in/out files. + CIF_GROUP - Get next group +.fi +.le +.ls RETURNS (bool) +TRUE if there is another set of file names available. FALSE if no +more primary files are found. +.le +.le +.ls cif_free (o) +Deallocates the CIF object. +.ls o (pointer) +The pointer to the CIF object to destroy. Value will be NULL on +return. +.le +.le + +The CIF variables can be found in the include file 'cif.h' under the +public definition section. Below is the current list followed by a +detailed explanation. + +.nf + # CIF structure variables: Primary file + CIF_p_file_list(o) + CIF_p_file(o) + CIF_p_ext(o) + CIF_p_status(o) + CIF_p_nloop(o) + + # CIF structure variables: Input Files + CIF_in_file_list(o,i) + CIF_in_file(o,i) + CIF_in_ext(o,i) + CIF_in_status(o,i) + CIF_in_nloop(o,i) + + # CIF structure variables: Output Files. + CIF_out_file_list(o,i) + CIF_out_file(o,i) + CIF_out_ext(o,i) + CIF_out_status(o,i) +.fi + +For all of the above variables, 'o' is the pointer to the CIF object +and 'i' is the particular input/output file list to access, since +there can be multiple input/output files. The definition of each +variable is as follows: +.ls CIF_p_file_list, CIF_in_file_list, CIF_out_file_list (char[CIF_SZ_FNAME]) +These variables contain the initial file lists for the primary, input, +and output files. The lists can contain wildcards, substitution, and +"@file" specifications. Anything that is consistent with the IRAF +'imtopen' IMIO call. These variables have to be set after the call to +'cif_alloc' but before calling 'cif_next'. + +The output list is used a bit differently from the input lists. If +the next file name from an output list is a directory, the output file +name will be the same as the current primary file, but with this +directory. If the output list is empty, and the last name retrieved +from the output list is not a directory, then the output filename will +be the same as the current primary file, depending on the value of +CIF_out_ext, see below. If the output list is empty and the last file +from the output list was a directory, that directory will be used for +all subsequent primary files. +.le +.ls CIF_p_ext, CIF_in_ext, CIF_out_ext (char[CIF_SZ_FNAME]) +These variables contain the default file name extension to use for +each file. The default extensions do not have to be specified, i.e. +the value of these variables is an empty string. In that case, the +actions described below for each variable does not occur. The +symantics of the _EXT variable is slightly different for each type of +file: +.ls CIF_p_ext +If the next primary file, as retrieved from the primary file list, +does not exist, replace the original extension with this extension. +If the file still does not exist, the call to cif_next will error. +.le +.ls CIF_in_ext +This variable is used in two different ways. If the input file list +is empty, then this extension is placed on the current primary file +and the file is looked for. If the input list is not empty but the +next input file does not exist, this extension replaces the original +extension and existance is checked again. +.le +.ls CIF_out_ext +If specified, this extension is always placed on the output file name. +.le +.le +.ls CIF_p_nloop, CIF_in_nloop (int) +These variable specify how many calls to 'cif_next' must occur before +the next group/file is retrieved from the particular primary or input +list. The default value is 1, or every time 'cif_next' is called, +retrieve the next group/file. This is useful when a single group in +either the primary or input file corresponds to a number of groups in +another input file (or primary file). + +The output files don't have a counter, since the output file names are +created based on the primary file. +.le +.ls CIF_p_file, CIF_in_file, CIF_out_file (char[CIF_SZ_FNAME]) +On return from 'cif_next', these variables contain the next set of +file names. The validity of the name contained in each variable is +determined by the corresponding *_STATUS variable, see below. If any +of the files are images, a group specification is appended. +.le +.ls CIF_p_status, CIF_in_status, CIF_out_status (int) +The status or validity of the names contained in the *_FILE variables +after a call to 'cif_next'. The possible values are: +.ls CIF_OK +The name represents another file, different from the name returned by +a previous call to 'cif_next'. For the primary and input files, the +file exists. For output files, the file does not exist. +.le +.ls CIF_NONE +For input files, there is no more files in that particular input list. +The value of CIF_in_file is invalid, i.e. contains "garbage". The +primary file and output files will never have this status value. This +is because, when there are no more primary files, 'cif_next' returns +FALSE and the output files are created based on the primary files. +.le +.ls CIF_SAME +For primary and input values, this value indicates that the file name +is the same as that returned from a previous call to 'cif_next'. A +file name will not change only because the value of *_NLOOP and the +current call to 'cif_next' implied to not change the file name. + +For output files, this status indicates that the output file name is +the same as the current primary file. This can occur if the output +file list is empty and either no default extension was specified, or +the default extension happens to be the same as the current primary +file. Note, this indicates that the character string of the output +file matches the character string of the current primary file. There +is no check whether the created files would actually be the same. +For example, if the current primary file is "root.ext", and the output +file is "./root.ext", the status would be CIF_OK, not CIF_SAME. See +CIF_EXISTS. +.le +.ls CIF_EXISTS +For output files only, this indicates that the file exists. +.le +.le +The one constant in use is CIF_SZ_FNAME, size of all character +variables used by CIF. +.ih +PRIVATE INTERFACE +Note: There won't be much discussion here. Remember: "Use the force, +read the source". + +The CIF object consists of two structures. The CIF file object, which +maintains the individual files, and the CIF structure which +manages the number of files. + +.ls Subroutines +The subroutines are as follows: +.ls pointer = cif_alloc_file_obj() +Create the CIF file object. This contains the information specific to +an individual file list. +.ls RETURNS (pointer) +Returns a pointer to a CIF FILE object. +.le +.le +.ls cif_free_file_obj (o) +Destroy a CIF FILE object. +.ls o (pointer) +The FILE object to destroy. On return, the value will be NULL. +.le +.le +.ls bool = cif_next_primary (o) +Get the next primary file and all input/output files. Besides the +routines in the public interface, this is the only one that deals with +the CIF structure. This routine, regardless of the group counts and +whether there are any groups left, retrieve the next files from the +primary, input, and output lists and populates the CIF public +variables appropriately. +.ls o (pointer) +A pointer to the CIF object. +.le +.ls RETURNS (boolean) +TRUE if there is another set of files. FALSE if there are no more +primary files. +.le +.le +.ls cif_base2name (o, p) +Get the next file name for the specified FILE object, using +information from the primary FILE object. +.ls o (pointer) +The FILE object to get the next name for. This should only be a +primary FILE object or an input FILE object. Output FILE objects use +'cif_out'. +.le +.ls p (pointer) +The FILE object for the primary file list. +.le +.le +.ls int = cif_file_type (fname) +Determine the type of file specified. If the file does not exist, the +routine generates an error. +.ls fname (char[ARB]) +The name of the file to determine the type of. +.le +.ls RETURNS (int) +A file type id. See 'cif.h' under the Private definitions for a list +of file types. +.le +.le +.ls bool = cif_next_group (o, loop) +Get the file name representing the next group of the specified file. +.ls o +The primary or input FILE object to get the next group of. +.le +.ls loop (int) +The number of times 'cif_next' has been called. Used to decide +whether another group should be returned or not. +.le +.ls RETURNS (bool) +TRUE if there is another group, even if the group has not changed. +FALSE if there are no more groups in the current image. +.le +.le +.ls cif_out (o, p) +Find the next output file name based on the primary file. +.ls o (pointer) +The output FILE object to get the name for. +.le +.ls p (pointer) +The primary FILE object. +.le +.le +.le +.endhelp +#--------------------------------------------------------------------------- +pointer procedure cif_alloc (n_in, n_out) + +int n_in # I: Number of secondary input files. +int n_out # I: Number of output files. + +# Declarations. +pointer cif_alloc_file_obj() # Alloce a CIF FILE object. +pointer o # The CIF object. +int i # Generic. + +errchk cif_alloc_file_obj, malloc + +begin + # Allocate the CIF object. + call malloc (o, CIF_SZ, TY_STRUCT) + + # Allocate the CIF FILE object for the primary file. + CIF_p(o) = cif_alloc_file_obj() + + # Allocate FILE objects for each input file. + CIF_n_in(o) = n_in + call malloc (CIF_in_ptr(o), CIF_n_in(o), TY_POINTER) + do i = 1, CIF_n_in(o) { + CIF_in(o,i) = cif_alloc_file_obj () + } + + # Allocate FILE objects for each output file. + CIF_n_out(o) = n_out + call malloc (CIF_out_ptr(o), CIF_n_out(o), TY_POINTER) + do i = 1, CIF_n_out(o) { + CIF_out(o,i) = cif_alloc_file_obj () + } + + # Initialize the loop count + CIF_loop(o) = 0 + + # That's all folks. + return (o) +end +#--------------------------------------------------------------------------- +# End of cif_alloc +#--------------------------------------------------------------------------- +procedure cif_free (o) + +pointer o # IO: CIF object, NULL on return. + +# Declarations. +int i # generic. + +errchk cif_free_file_obj, mfree + +begin + # Free FILE objects for each output file. + do i = 1, CIF_n_out(o) + call cif_free_file_obj (CIF_out(o,i)) + call mfree (CIF_out_ptr(o), TY_POINTER) + + # Free FILE objects for each input file. + do i = 1, CIF_n_in(o) + call cif_free_file_obj (CIF_in(o,i)) + call mfree (CIF_in_ptr(o), TY_POINTER) + + # Free the primary FILE object. + call cif_free_file_obj (CIF_p(o)) + + # Remove the object. + call mfree (o, TY_STRUCT) +end +#--------------------------------------------------------------------------- +# End of cif_free +#--------------------------------------------------------------------------- +pointer procedure cif_alloc_file_obj () + +# Declarations. +pointer o # The CIF FILE object. + +errchk malloc + +begin + # Get memory. + call malloc (o, CIF_SZ_FILE, TY_STRUCT) + call malloc (CIF_cbuf(o), CIF_SZ_FILE_CBUF, TY_CHAR) + + # Setup initial values. + call strcpy ("", CIF_file_list(o), CIF_SZ_FNAME) + call strcpy ("", CIF_file(o), CIF_SZ_FNAME) + CIF_list(o) = NULL + CIF_group(o) = NULL + call strcpy ("", CIF_ext(o), CIF_SZ_FNAME) + CIF_status(o) = CIF_NONE + CIF_nloop(o) = 1 + CIF_cg(o) = INDEFI + call strcpy ("", CIF_base(o), CIF_SZ_FNAME) + CIF_type(o) = INDEFI + + # That's all folks. + return (o) +end +#--------------------------------------------------------------------------- +# End of cif_alloc_file_obj +#--------------------------------------------------------------------------- +procedure cif_free_file_obj (o) + +pointer o # IO: CIF FILE object, NULL on return. + +# Declarations. +errchk imtclose, mfree, tp_close + +begin + # Close other opened objects. + if (CIF_list(o) != NULL) + call imtclose (CIF_list(o)) + if (CIF_group(o) != NULL) + call tp_close (CIF_group(o)) + + # That's all folks. + call mfree (CIF_cbuf(o), TY_CHAR) + call mfree (o, TY_STRUCT) +end +#--------------------------------------------------------------------------- +# End of cif_free_file_obj +#--------------------------------------------------------------------------- +bool procedure cif_next (o, type) + +pointer o # I: The CIF object. +int type # I: Get a group or file. + +# Declarations +bool another # True if another set of files are available. +bool bx # Generic. +bool cif_next_group() # Get next group. +bool cif_next_primary() # Get next primary files. +int i # Generic. +int imtlen() # Length of a file list. +pointer imtopen() # Open an file list. + +errchk imtlen, imtopen + +begin + # Increment the loop count. + CIF_loop(o) = CIF_loop(o) + 1 + + # If the lists have not been opened, do it now. + if (CIF_list(CIF_p(o)) == NULL) { + CIF_list(CIF_p(o)) = imtopen (CIF_file_list(CIF_p(o))) + if (imtlen (CIF_list(CIF_p(O))) <= 0) + call error (1, "cif: no input files specified") + do i = 1, CIF_n_in(o) + CIF_list(CIF_in(o,i)) = imtopen (CIF_file_list(CIF_in(o,i))) + do i = 1, CIF_n_out(o) + CIF_list(CIF_out(o,i)) = imtopen (CIF_file_list(CIF_out(o,i))) + another = cif_next_primary (o) + } + + # Else, if type is FILE, just get next set of files. + else if (type == CIF_NEXT_FILE) + another = cif_next_primary (o) + + # Else, loop through groups. + else { + if (cif_next_group (CIF_p(o), CIF_loop(o))) { + + # Loop through all the inputs. + do i = 1, CIF_n_in(o) + bx = cif_next_group (CIF_in(o,i), CIF_loop(o)) + + # Loop through all the outputs. + do i = 1, CIF_n_out(o) + call cif_out (CIF_out(o,i), CIF_p(o)) + + # There is another file. + another = true + } + + # Else, get the next set of files. + else + another = cif_next_primary (o) + } + + # That's all folks. + return (another) +end +#--------------------------------------------------------------------------- +# End of cif_next +#--------------------------------------------------------------------------- +bool procedure cif_next_primary (o) + +pointer o # I: The CIF object. + +# Declarations. +bool another # True if another set of files is available. +int i # Generic. +int imtgetim() # Get next file from file list. +char sx[SZ_LINE] # Generic string. + +errchk imtgetim + +begin + # Open next primary image. If there are no more, then + # that's all. + if (imtgetim (CIF_list(CIF_p(o)), CIF_base(CIF_p(o)), + CIF_SZ_FNAME) != EOF) { + call cif_base2name (CIF_p(o), CIF_p(o)) + if (CIF_status(CIF_p(o)) == CIF_NONE) { + call sprintf (sx, SZ_LINE, "cif: no primary file %s") + call pargstr (CIF_base(CIF_p(o))) + call error (1, sx) + } + + # Open the next set of input files. + do i = 1,CIF_n_in(o) { + if (imtgetim (CIF_list(CIF_in(o,i)), CIF_base(CIF_in(o,i)), + CIF_SZ_FNAME) == EOF) + call strcpy ("", CIF_base(CIF_in(o,i)), CIF_SZ_FNAME) + call cif_base2name (CIF_in(o,i), CIF_p(o)) + } + + # Open the next set of output files. + do i = 1, CIF_n_out(o) { + CIF_status(CIF_out(o,i)) = CIF_OK + if (imtgetim (CIF_list(CIF_out(o,i)), CIF_base(CIF_out(o,i)), + CIF_SZ_FNAME) == EOF) { + if (IS_INDEFI(CIF_type(CIF_out(o,i)))) + CIF_type(o,i) = CIF_GENERIC + else + CIF_status(CIF_out(o,i)) = CIF_SAME + } + + call cif_out (CIF_out(o,i), CIF_p(o)) + } + + # Indicate that another set of files are available. + another = true + + } else + another = false + + # That's all folks. + return (another) +end +#--------------------------------------------------------------------------- +# End of cif_next_primary +#--------------------------------------------------------------------------- +procedure cif_base2name (o, p) + +pointer o # I: CIF FILE Object to find name for. +pointer p # I: CIF FILE Object of primary file. + +# Declarations +bool bx # Generic. +int cif_file_type() # Determine file type of file. +int i # Generic. +int strlen() # Get length of string. +bool tp_fetch() # Get next group. +pointer tp_open() # Open a group list. + +errchk tp_close, tp_fetch, tp_open + +begin + # If there is a group list open, close it. + if (CIF_group(o) != NULL) + call tp_close (CIF_group(o)) + + # Determine file type. If there is an error, try with + # the default extension. If that doesn't exist, try default + # extension of the primary name. + CIF_status(o) = CIF_OK + if (strlen(CIF_base(o)) <= 0) { + call change_ext (CIF_base(p), CIF_ext(o), CIF_file(o), + CIF_SZ_FNAME) + iferr (CIF_type(o) = cif_file_type (CIF_file(o))) + CIF_status(o) = CIF_NONE + } else { + call strcpy (CIF_base(o), CIF_file(o), CIF_SZ_FNAME) + iferr (CIF_type(o) = cif_file_type (CIF_file(o))) { + call change_ext (CIF_file(o), CIF_ext(o), CIF_file(o), + CIF_SZ_FNAME) + iferr (CIF_type(o) = cif_file_type (CIF_file(o))) + CIF_status(o) = CIF_NONE + } + } + + # Make the new name the base. + if (CIF_status(o) == CIF_OK) { + call strcpy (CIF_file(o), CIF_base(o), CIF_SZ_FNAME) + + # If the file is an image, open the group list. + if (CIF_type(o) == CIF_IMAGE) { + CIF_group(o) = tp_open (CIF_file(o), 0, i) + bx = tp_fetch (CIF_group(o), CIF_file(o)) + } + CIF_cg(o) = 1 + } +end +#--------------------------------------------------------------------------- +# End of cif_base2name +#--------------------------------------------------------------------------- +int procedure cif_file_type (fname) + +char fname[ARB] # I: The file to determine type of. + +# Declarations. +int access() # Get file access. +pointer immap() # Open an image. +pointer px # Generic. +int strlen() # Get length of string. +int type # Type of file. + +errchk access, imunmap + +begin + if (strlen (fname) <= 0) + call error (1, "cif: Unknown type") + else ifnoerr (px = immap (fname, READ_ONLY, NULL)) { + type = CIF_IMAGE + call imunmap (px) + } else if (access (fname, 0, 0) == YES) + type = CIF_GENERIC + else + call error (1, "cif: Unknown type") + + return (type) +end +#--------------------------------------------------------------------------- +# End of cif_file_type +#--------------------------------------------------------------------------- +bool procedure cif_next_group (o, loop) + +pointer o # I: The CIF FILE object. +int loop # I: Current loop count. + +# Declarations +bool tp_fetch() # Get next group. + +errchk tp_fetch + +begin + # Is this file a type to have groups? + if (CIF_type(o) == CIF_IMAGE) { + + # Is this loop one to change on? + if (mod (loop-1, CIF_nloop(o)) == 0) { + + # Get the next group. + if (tp_fetch (CIF_group(o), CIF_file(o))) { + CIF_status(o) = CIF_OK + CIF_cg(o) = CIF_cg(o) + 1 + } + + # Else, no more data. + else + CIF_status(o) = CIF_NONE + } + + # Nope, keep it the same. + else + CIF_status(o) = CIF_SAME + } + + # Else, nope, no groups here. + else + CIF_status(o) = CIF_NONE + + # Return true if a file exists. + return (CIF_status(o) != CIF_NONE) +end +#--------------------------------------------------------------------------- +# End of cif_next_group +#--------------------------------------------------------------------------- +procedure cif_out (o, p) + +pointer o # I: CIF FILE Object to get output name. +pointer p # I: Primary CIF FILE Object to get info. + +# Declarations +int access() # Is file accessable? +int cl_index, cl_size # Cluster info. +char dir[CIF_SZ_FNAME] # Directory of the file name. +char ext[CIF_SZ_FNAME] # Extension of the file name. +int i # Generic. +int isdirectory() # Is a file a directory? +char ksection[CIF_SZ_FNAME] # Ksection of the file name. +char root[CIF_SZ_FNAME] # Root of the file name. +char section[CIF_SZ_FNAME] # Section of the file name. +bool streq() # Are strings equal? +int strlen() # Get length of string. +char sx[1] # Generic. + +errchk access, fbuild, fparse, isdirectory + +begin + # If a new input, determine what it is. + if (CIF_status(o) != CIF_SAME) { + if (strlen (CIF_base(o)) <= 0) + CIF_type(o) = CIF_SAME_ROOT + else if (isdirectory (CIF_base(o), root, SZ_PATHNAME) > 0) + CIF_type(o) = CIF_DIRECTORY + else + CIF_type(o) = CIF_GENERIC + } + + # Create the new file name. + call fparse (CIF_file(p), dir, CIF_SZ_FNAME, root, CIF_SZ_FNAME, + ext, CIF_SZ_FNAME, cl_index, cl_size, section, + CIF_SZ_FNAME, ksection, CIF_SZ_FNAME) + switch (CIF_type(o)) { + case CIF_DIRECTORY: + call strcpy (CIF_base(o), dir, CIF_SZ_FNAME) + + case CIF_GENERIC: + call fparse (CIF_base(o), dir, CIF_SZ_FNAME, root, CIF_SZ_FNAME, + ext, CIF_SZ_FNAME, i, i, sx, 1, sx, 1) + } + + # If a different extension is supplied, use it. + if (strlen (CIF_ext(o)) > 0) { + call strcpy (".", ext, CIF_SZ_FNAME) + call strcat (CIF_ext(o), ext, CIF_SZ_FNAME) + } + + # Build the new file name. + call fbuild (dir, root, ext, cl_index, cl_size, section, ksection, + CIF_file(o), CIF_SZ_FNAME) + + # Set status if the name is the same as the primary file. + if (streq (CIF_file(p), CIF_file(o))) + CIF_status(o) = CIF_SAME + else { + if (access (CIF_file(o), 0, 0) == YES) + CIF_status(o) = CIF_EXISTS + else + CIF_status(o) = CIF_OK + } +end +#--------------------------------------------------------------------------- +# End of cif_out +#--------------------------------------------------------------------------- +procedure cif_test() + +pointer cif, cif_alloc() +bool cif_next() +int clgeti(), i + +begin + cif = cif_alloc (2, 1) + + call clgstr ("primary", CIF_p_file_list(cif), CIF_SZ_FNAME) + call clgstr ("p_ext", CIF_p_ext(cif), CIF_SZ_FNAME) + CIF_p_nloop(cif) = clgeti ("p_loop") + call clgstr ("in1", CIF_in_file_list(cif,1), CIF_SZ_FNAME) + call clgstr ("in1_ext", CIF_in_ext(cif,1), CIF_SZ_FNAME) + CIF_in_nloop(cif,1) = clgeti ("in1_loop") + call clgstr ("in2", CIF_in_file_list(cif,2), CIF_SZ_FNAME) + call clgstr ("in2_ext", CIF_in_ext(cif,2), CIF_SZ_FNAME) + CIF_in_nloop(cif,2) = clgeti ("in2_loop") + call clgstr ("out1", CIF_out_file_list(cif,1), CIF_SZ_FNAME) + call clgstr ("out1_ext", CIF_out_ext(cif,1), CIF_SZ_FNAME) + + while (cif_next (cif, CIF_NEXT_GROUP)) { + call printf ("Primary file == '%s'") + call pargstr (CIF_p_file(cif)) + if (CIF_p_status(cif) == CIF_SAME) + call printf (" (same as previous)") + call printf ("\n") + + do i = 1, 2 { + switch (CIF_in_status(cif,i)) { + case CIF_OK: + call printf (" Input %d is '%s'\n") + call pargi (i) + call pargstr (CIF_in_file(cif,i)) + case CIF_NONE: + call printf (" No files for input %d\n") + call pargi (i) + case CIF_SAME: + call printf (" Input %d is '%s' (same as previous)\n") + call pargi (i) + call pargstr (CIF_in_file(cif,i)) + } + } + + call printf (" Output file is '%s'") + call pargstr (CIF_out_file(cif,1)) + if (CIF_out_status(cif,1) == CIF_EXISTS) + call printf (" (file exists)") + else if (CIF_out_status(cif,1) == CIF_SAME) + call printf (" (same as input)") + call printf ("\n") + } + + call cif_free (cif) +end +#--------------------------------------------------------------------------- +# End of cif_test +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/clgnone.x b/pkg/utilities/nttools/stxtools/clgnone.x new file mode 100644 index 00000000..b6fde15c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/clgnone.x @@ -0,0 +1,37 @@ +# CLGNONE -- Get a string parameter whose value may be "none" +# +# B.Simon 20-Jun-94 original +# B.Simon 30-Jan-95 moved to stxtools + +procedure clgnone (param, value, maxch) + +char param[ARB] # i: parameter name +char value[ARB] # o: parameter value +int maxch # i: maximum length of value +#-- +pointer sp, temp1, temp2 +bool streq() + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (temp1, maxch, TY_CHAR) + call salloc (temp2, maxch, TY_CHAR) + + # Read parameter and convert to lower case for simpler comparison + + call clgstr (param, Memc[temp1], maxch) + call strcpy (Memc[temp1], Memc[temp2], maxch) + call strjust (Memc[temp2]) + + # If value is none, set to null string + + if (Memc[temp2] == EOS || streq (Memc[temp2], "none")) { + value[1] = EOS + } else { + call strcpy (Memc[temp1], value, maxch) + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/copyimg.x b/pkg/utilities/nttools/stxtools/copyimg.x new file mode 100644 index 00000000..0248cfa9 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/copyimg.x @@ -0,0 +1,78 @@ +include <imhdr.h> + +# COPYIMG -- Copy one image to another +# +# B.Simon 02-Mar-92 Original +# B.Simon 16-Mar-94 Delete fast copy, check for existing image + +procedure copyimg (old, new) + +char old[ARB] # i: old image +char new[ARB] # i: new image +#-- +int npix, junk +pointer buf1, buf2, im1, im2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] + +int imaccess() +int imgnls(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnll(), impnlr(), impnld(), impnlx() +pointer immap() + +errchk immap, imunmap + +begin + # Map the input and output images + # Code adapted from iraf's imcopy task + + im1 = immap (old, READ_ONLY, 0) + if (imaccess (new, READ_WRITE) == NO) { + im2 = immap (new, NEW_COPY, im1) + } else { + im2 = immap (new, READ_WRITE, NULL) + } + + # Setup start vector for sequential reads and writes + + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + # Copy the image. + + npix = IM_LEN(im1, 1) + switch (IM_PIXTYPE(im1)) { + case TY_SHORT: + while (imgnls (im1, buf1, v1) != EOF) { + junk = impnls (im2, buf2, v2) + call amovs (Mems[buf1], Mems[buf2], npix) + } + case TY_USHORT, TY_INT, TY_LONG: + while (imgnll (im1, buf1, v1) != EOF) { + junk = impnll (im2, buf2, v2) + call amovl (Meml[buf1], Meml[buf2], npix) + } + case TY_REAL: + while (imgnlr (im1, buf1, v1) != EOF) { + junk = impnlr (im2, buf2, v2) + call amovr (Memr[buf1], Memr[buf2], npix) + } + case TY_DOUBLE: + while (imgnld (im1, buf1, v1) != EOF) { + junk = impnld (im2, buf2, v2) + call amovd (Memd[buf1], Memd[buf2], npix) + } + case TY_COMPLEX: + while (imgnlx (im1, buf1, v1) != EOF) { + junk = impnlx (im2, buf2, v2) + call amovx (Memx[buf1], Memx[buf2], npix) + } + default: + call error (1, "unknown pixel datatype") + } + + # Unmap the images + + call imunmap (im2) + call imunmap (im1) + +end diff --git a/pkg/utilities/nttools/stxtools/doc/wcs.doc b/pkg/utilities/nttools/stxtools/doc/wcs.doc new file mode 100644 index 00000000..8154a944 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/doc/wcs.doc @@ -0,0 +1,177 @@ +Routines for conversion between pixel coordinates and world coordinates. + + This package contains the following high-level routines for converting +between world coordinates and pixel coordinates: + +xt_wcs_init initialize structure for world coordinate system +xt_wcs_init_c initialize from input cdelt, crota, etc +xt_wcs_init_cd initialize from input CD matrix, etc +xt_wc_pix convert from world coordinates to pixel coordinates +xt_pix_wc convert from pixel coordinates to world coordinates +xt_wcs_free deallocate wcs struct + +After calling any one of the three initialization routines, either or both +of the conversion routines (xt_wc_pix, xt_pix_wc) may be called any number +of times. When finished, xt_wcs_free should be called to deallocate memory +that was allocated by the initialization routine. + + Eight different projection geometries are currently implemented for +spherical coordinates. The projection type is obtained from the CTYPE +parameter, or the type defaults to gnomonic if nothing is specified in +CTYPE. Here is a list of CTYPE values for the right ascension axis with +the various projection types. For Aitoff and Mercator projections the +reference pixel is assumed to be on the equator. In addition, for Aitoff +projection the difference between right ascension and RA at the reference +pixel is limited to 180 degrees. + + CTYPE projection type + ----- --------------- + RA---TAN gnomonic (tangent) + RA---SIN radial distance proportional to sine of angle + RA---ARC radial distance proportional to angle + RA---NCP north celestial pole + RA---GBS global sine (equal area) + RA---STG stereographic + RA---AIT Aitoff equal area + RA---MER Mercator + + + To use the following sample program, extract into a file "ttt.x" +and compile and link with: + + xc -p tables ttt.x -lstxtools + +task ttt + +include <imhdr.h> + +procedure ttt() + +pointer im, wcs +double phys[IM_MAXDIM] +real pix[IM_MAXDIM], opix[IM_MAXDIM] +int naxis, k +char input[SZ_FNAME] +pointer immap() +int scan() + +begin + call clgstr ("input", input, SZ_FNAME) + im = immap (input, READ_ONLY, NULL) + naxis = IM_NDIM(im) + call xt_wcs_init (im, wcs) # initialize + call imunmap (im) + + call printf ("naxis = %d\n") + call pargi (naxis) + call printf ("enter pixel coordinates\n") + + while (scan() != EOF) { + do k = 1, naxis + call gargr (pix[k]) + call xt_pix_wc (wcs, pix, phys, naxis) # to world coords + call xt_wc_pix (wcs, phys, opix, naxis) # to pixel coords + # Print the input pixel coordinates, the world coordinates, + # and the output pixel coordinates (which should be the same + # as the input). + do k = 1, naxis { + call printf ("%.3f %18.10g %.3f\n") + call pargr (pix[k]) + call pargd (phys[k]) + call pargr (opix[k]) + } + } + call xt_wcs_free (wcs) # free memory +end + + + +# xt_wcs_init -- initialize wcs struct +# This routine allocates space for a structure describing the world +# coordinate system for an image, fills in the values or defaults, and +# returns a pointer to that structure. + +call xt_wcs_init (im, wcs) + +pointer im # i: pointer to image descriptor +pointer wcs # o: pointer to world coord system struct + + +# xt_wcs_init_c -- initialize wcs struct +# xt_wcs_init_c and xt_wcs_init_cd allocate space for a structure +# describing the world coordinate system for an image, fill in the values +# or defaults, and return a pointer to that structure. They differ from +# xt_wcs_init in that these take the coordinate parameters as arguments +# rather than getting them from the image. +# xt_wcs_init_c takes cdelt & crota, and xt_wcs_init_cd takes the CD matrix. + +call xt_wcs_init_c (crval, crpix, cdelt, crota, ctype, naxis, wcs) + +double crval[naxis] # i: coordinate values at reference pixel +real crpix[naxis] # i: reference pixel +real cdelt[naxis] # i: pixel spacing +real crota # i: rotation angle (if 2-D) +char ctype[SZ_CTYPE,naxis] # i: e.g. "RA---TAN" +int naxis # i: size of arrays +pointer wcs # o: pointer to world coord system struct + + +call xt_wcs_init_cd (crval, crpix, cd, ctype, naxis, wcs) + +double crval[naxis] # i: coordinate values at reference pixel +real crpix[naxis] # i: reference pixel +real cd[naxis,naxis] # i: CD matrix +char ctype[SZ_CTYPE,naxis] # i: e.g. "RA---TAN" +int naxis # i: size of arrays +pointer wcs # o: pointer to world coord system struct + + +# xt_wcs_free -- deallocate wcs struct +# This routine deallocates space for a wcs structure. + +call xt_wcs_free (wcs) + +pointer wcs # io: pointer to world coord system struct + + + +# xt_wc_pix -- wcs to pixels +# This routine converts world coordinates to pixel coordinates. +# +# In the 1-D case, CRVAL is subtracted from the coordinate, the +# result is divided by CDELT (same as CD1_1), and CRPIX is added. +# +# For 2-D or higher dimension, if two of the axes are like RA and Dec, +# the input coordinates are converted to standard coordinates Xi +# and Eta. The (Xi, Eta) vector is then multiplied on the left by +# the inverse of the CD matrix, and CRPIX is added. +# The units for axes like Ra & Dec are degrees, not hours or radians. +# For linear axes the conversion is the same as for 1-D. + +call xt_wc_pix (wcs, phys, pix, naxis) + +pointer wcs # i: pointer to world coord system struct +double phys[naxis] # i: physical (world) coordinates (e.g. degrees) +real pix[naxis] # o: pixel coordinates +int naxis # i: size of arrays + + + +# xt_pix_wc -- pixels to wcs +# This routine converts pixel coordinates to world coordinates. +# +# In the 1-D case, CRPIX is subtracted from the pixel coordinate, +# the result is multiplied by CDELT (same as CD1_1), and CRVAL is added. +# +# For 2-D or higher dimension, CRPIX is subtracted, and the result is +# multiplied on the left by the CD matrix. If two of the axes are like +# RA and Dec, the pixel coordinates are converted to standard coordinates +# Xi and Eta. The (Xi, Eta) vector is then converted to differences +# between RA and Dec and CRVAL, and then CRVAL is added to each coordinate. + +call xt_pix_wc (wcs, pix, phys, naxis) + +pointer wcs # i: pointer to world coord system struct +real pix[naxis] # i: pixel coordinates +double phys[naxis] # o: physical (world) coordinates (e.g. degrees) +int naxis # i: size of arrays diff --git a/pkg/utilities/nttools/stxtools/errxit.x b/pkg/utilities/nttools/stxtools/errxit.x new file mode 100644 index 00000000..45b5a7a3 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/errxit.x @@ -0,0 +1,30 @@ +# ERRXIT -- Take an error exit and set the error code + +# This error exit routine is used on VMS system. The VMS symbol $status +# will be set to the exit_code, so that the process running this program +# will know the error condition that terminated the program. In order +# to avoid conflict with other VMS exit codes, it would be best if the +# exit_code is set to an odd value greater than one. +# +# Nelson Zarate 30-Nov-95 original +# Perry Greenfield 18-Apr-95 change exit code from 122 to 2 +# so that misleading DCL error message +# is not given (severity level remains +# the same: 2 --> ERROR). 122 results +# in a "DEVICE NOT MOUNTED" message. + +procedure errxit (exit_code) + +int exit_code +#-- + +begin + # Reset the exit code to a constant value for this routine that + # will be called on a VMS system. Other system will run the + # errxit.c that lives in tables$lib/stxtools/errxit.c to be inserted + # at compilation time by mkpkg.sf.. + # NZ Nov 30 1995 + exit_code = 2 + + call exit (exit_code) +end diff --git a/pkg/utilities/nttools/stxtools/fbuild.x b/pkg/utilities/nttools/stxtools/fbuild.x new file mode 100644 index 00000000..1dcf6448 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/fbuild.x @@ -0,0 +1,97 @@ +#--------------------------------------------------------------------------- +.help fbuild Nov93 source +.ih +NAME +fbuild -- Build a file name based on components. +.ih +USAGE +call fbuild (dir, root, ext, clindex, clsize, section, ksection, + file, sz_file) +.ih +ARGUMENTS +.ls dir (Input: char[ARB]) +The directory specification. This may be blank. If not, it should +include the directory separator, i.e. a '$' or '/' at the end of the +directory. +.le +.ls root (Input: char[ARB]) +The rootname specification. This may be left blank. No other +punctuation besides what goes into a rootname is required. +.le +.ls ext (Input: char[ARB]) +The file extension specification. This may be left blank. If +specified, the extension separater must be prepended, i.e. a period +'.' must be the first character. +.le +.ls clindex (Input: int) +The cl index or group number. If zero, it will not be placed into the +pathname. +.le +.ls clsize (Input: int) +The cl size (or maximum group) number. If zero, it will not be placed +into the pathname. +.le +.ls section (Input: char[ARB]) +The section specification. Must include the surrounding '[' and ']' +section separators. +.le +.ls ksection (Input: char[ARB]) +The ksection specification. Must include the surrounding '[' and ']' +ksection separators. +.le +.ls file (Output: char[sz_file]) +The output pathname. +.le +.ls sz_file (Input: int) +The maximum size of the output file specification. +.le +.ih +DESCRIPTION +fbuild builds a pathname based on individual components. This +complements the routine fparse. For example, if a full pathname +exists, a call to fparse followed by a call to fbuild should reproduce +the pathname. +.ih +REFERENCES +Jonathan Eisenhamer, STSDAS +.ih +SEE ALSO +fparse +.endhelp +#--------------------------------------------------------------------------- +procedure fbuild (dir, root, ext, clindex, clsize, section, ksection, + file, sz_file) + +char dir[ARB] # I: Directory specification. +char root[ARB] # I: Rootname specification. +char ext[ARB] # I: Extension specification. +int clindex # I: Index number. +int clsize # I: Size number. +char section[ARB] # I: Section specification. +char ksection[ARB] # I: KSection specification. +char file[sz_file] # O: File name. +int sz_file # I: Maximum size of the file name. + +char Index[SZ_PATHNAME] # The Group specification. + +begin + call strcpy (dir, file, sz_file) + call strcat (root, file, sz_file) + call strcat (ext, file, sz_file) + call strcpy ("", Index, SZ_PATHNAME) + if (clindex > 0) + if (clsize > 0) { + call sprintf (Index, SZ_PATHNAME, "[%d/%d]") + call pargi (clindex) + call pargi (clsize) + } else { + call sprintf (Index, SZ_PATHNAME, "[%d]") + call pargi (clindex) + } + call strcat (Index, file, sz_file) + call strcat (section, file, sz_file) + call strcat (ksection, file, sz_file) +end +#--------------------------------------------------------------------------- +# End of fbuild +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/fparse.x b/pkg/utilities/nttools/stxtools/fparse.x new file mode 100644 index 00000000..33dee6ff --- /dev/null +++ b/pkg/utilities/nttools/stxtools/fparse.x @@ -0,0 +1,170 @@ +#--------------------------------------------------------------------------- +.help fparse Aug98 xtools +.ih +NAME +fparse -- Parse a file name +.ih +USAGE +call fparse (input, dir, dir_size, root, root_size, ext, ext_size, + cl_index, cl_size, section, section_size, ksection, + ksection_size) +.ih +ARGUMENTS +.ls input (I: char[ARB]) +The input file name to parse into its components. +.le +.ls dir (O: char[dir_size]) +The directory component of the file name. Includes the directory +separator character. +.le +.ls dir_size (I: int) +The maximum length of the string to place in the dir argument. +.le +.ls root (O: char[root_size]) +The root component of the file name. Includes any wildcard characters +specified for the root. +.le +.ls root_size (I: int) +The maximum length of the string to place in the root argument. +.le +.ls ext (O: char[ext_size]) +The extension component of the file name. DOES NOT INCLUDE the +extension separator, i.e. the ".". +.le +.ls ext_size (I: int) +The maximum length of the string to place in the ext argument. +.le +.ls cl_index (O: int) +The cluster or group index found in the file name. If none is found, +this returns -1. Before IRAF v2.11, returned 0. +.le +.ls cl_size (O: int) +The number of clusters or groups found in the file name. If none is +found, this returns -1. Before IRAF v2.11, returned 0. +.le +.ls section (O: char[section_size]) +The image section specification part of the file name. Will contain +the standard image section specifications. +.le +.ls section_size (I: int) +The maximum length of the string to place in the section argument. +.le +.ls ksection (O: char[ksection_size]) +This is the "catchall". If the filename cannot be parsed into the +form "dir$root.ext[cl_index/cl_size][section]", ksection will contain +the extra. +.le +.ih +DESCRIPTION +This routine basically performs the individual functions of fnldir, +fnext, and fnroot, and the "illegal" imparse. The only distinct +advantage to this routine is that wildcard characters, and the +relative directory characters ".", and ".." can be present in the file +name. +.ih +BUGS +This routine calls the illegal routine imparse. If the image naming +conventions in IMIO ever change, this routine will surely break all to +pieces. +.endhelp +#--------------------------------------------------------------------------- +# +# M.D. De La Pena - 11 August 1998: updated internal documentation for +# cl_index and cl_size to reflect changes made for IRAF v2.11. +# +procedure fparse (input, dir, dir_size, root, root_size, ext, ext_size, + cl_index, cl_size, section, section_size, ksection, + ksection_size) + +char input[ARB] # I: Input pathname +char dir[dir_size] # O: Directory part of pathname. +int dir_size # I: Max size of dir. +char root[root_size] # O: Root part of pathname. +int root_size # I: Max size of root. +char ext[ext_size] # O: Extension part of pathname. +int ext_size # I: Max size of extension. +int cl_index # O: The cluster index. +int cl_size # O: The cluster size. +char section[section_size] # O: The section part of pathname. +int section_size # I: Max size of section. +char ksection[ksection_size] # O: The remainder of the pathname. +int ksection_size # I: Max size of ksection. + +# Declarations +int i # Generic. +int len_dir # Length of the directory spec. + +pointer cluster # Cluster. +pointer last_period # Pointer to the last period. +pointer new_cluster # Cluster without the directory spec. +pointer ptr # Pointer into strings. +pointer sp # Stack pointer. + +string wildcards "*?" + +# Function prototypes. +int fnldir(), stridxs() +bool streq() + +begin + + call smark(sp) + call salloc (cluster, SZ_LINE, TY_CHAR) + + # Parse the name with the (illegal) call imparse. + call imparse (input, Memc[cluster], SZ_LINE, ksection, + ksection_size, section, section_size, cl_index, + cl_size) + + # Further parse the the cluster name into directory, root, + # and extension. + # Wildcards are a problem. The above only deals with fully qualified + # pathnames, not templates. But, it seems it could be done. Scan + # the directory for wildcards and try to parse out a bit more. The + # assumption made is that directories cannot be wildcarded. + root[1] = EOS + ext[1] = EOS + len_dir = fnldir (Memc[cluster], dir, dir_size) + i = stridxs (wildcards, dir) + if (i > 0) { + dir[i] = EOS + len_dir = fnldir (dir, dir, dir_size) + } + + # Now there is just root and extension. Check to see if root is just + # the relative directory names. If so, append them to the directory + # specification. + new_cluster = cluster + len_dir + if (streq (Memc[new_cluster], ".") || streq (Memc[new_cluster], "..")) { + call strcat (Memc[new_cluster], dir, dir_size) + call strcat ("/", dir, dir_size) + } + + # Else, find the extension. This is just the last found "." in the + # specification. + else { + last_period = NULL + ptr = new_cluster + while (Memc[ptr] != EOS) { + if ( Memc[ptr] == '.') + last_period = ptr + ptr = ptr + 1 + } + if (last_period == NULL) { + call strcpy (Memc[new_cluster], root, root_size) + ext[1] = EOS + } else { + Memc[last_period] = EOS + call strcpy (Memc[new_cluster], root, root_size ) + Memc[last_period] = '.' + call strcpy (Memc[last_period], ext, ext_size) + } + } + + # That's all folks. + call sfree(sp) + +end +#--------------------------------------------------------------------------- +# End of fparse +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/grmimy.x b/pkg/utilities/nttools/stxtools/grmimy.x new file mode 100644 index 00000000..bd30f93e --- /dev/null +++ b/pkg/utilities/nttools/stxtools/grmimy.x @@ -0,0 +1,68 @@ +include <imhdr.h> + +#--------------------------------------------------------------------------- +.help grm_imcopy Oct92 source +.ih +NAME +grm_imcopy -- Copy images given their image descriptors. +.endhelp +#--------------------------------------------------------------------------- +procedure grm_imcopy (in, out) + +pointer in # I: Input image descriptor of image to copy. +pointer out # I: Output image descriptor of resultant image. + +# Declarations. +long v1[IM_MAXDIM], v2[IM_MAXDIM] # Line and section counters. + +int junk # Generic. +int npix # Length of a line of data. + +pointer buf1, buf2 # Data buffers. + +# Function Prototypes. +int imgnls(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnll(), impnlr(), impnld(), impnlx() + +begin + + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + # Copy the image. + npix = IM_LEN(in, 1) + switch (IM_PIXTYPE(in)) { + case TY_SHORT: + while (imgnls (in, buf1, v1) != EOF) { + junk = impnls (out, buf2, v2) + call amovs (Mems[buf1], Mems[buf2], npix) + } + case TY_USHORT, TY_INT, TY_LONG: + while (imgnll (in, buf1, v1) != EOF) { + junk = impnll (out, buf2, v2) + call amovl (Meml[buf1], Meml[buf2], npix) + } + case TY_REAL: + while (imgnlr (in, buf1, v1) != EOF) { + junk = impnlr (out, buf2, v2) + call amovr (Memr[buf1], Memr[buf2], npix) + } + case TY_DOUBLE: + while (imgnld (in, buf1, v1) != EOF) { + junk = impnld (out, buf2, v2) + call amovd (Memd[buf1], Memd[buf2], npix) + } + case TY_COMPLEX: + while (imgnlx (in, buf1, v1) != EOF) { + junk = impnlx (out, buf2, v2) + call amovx (Memx[buf1], Memx[buf2], npix) + } + default: + call error (1, "unknown pixel datatype") + } + +end +#--------------------------------------------------------------------------- +# End of grm_imcopy +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/isblank.x b/pkg/utilities/nttools/stxtools/isblank.x new file mode 100644 index 00000000..85edb9d7 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/isblank.x @@ -0,0 +1,18 @@ +include <ctype.h> + +# ISBLANK -- Return true if the string is entirely white space +# +# B.Simon 11-Nov-87 First Code + +bool procedure isblank (str) + +char str[ARB] # i: string to be tested +int ip + +begin + do ip = 1, ARB + if (str[ip] == EOS) + return (true) + else if (! IS_WHITE(str[ip]) ) + return (false) +end diff --git a/pkg/utilities/nttools/stxtools/lubksb.f b/pkg/utilities/nttools/stxtools/lubksb.f new file mode 100644 index 00000000..429cf2e4 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/lubksb.f @@ -0,0 +1,50 @@ + SUBROUTINE LUBKSB (A, N, NP, INDX, B) + +C Solves a matrix equation AX = B. Before using this routine you must +C call ludcmp to decompose the matrix A (in-place) into lower and upper +C triangular portions. The vector B is input to this routine, and the +C answer X is returned in B. +C +C real a(np,np) i: matrix returned by ludcmp +C int n i: logical size of a is n x n +C int np i: space allocated for a is np x np +C int indx(n) i: index returned by ludcmp +C real b(n) io: input b, output x in equation ax = b +C +C 1988 Oct 28 From Numerical Recipes + + INTEGER N, NP + REAL A(NP,NP) + INTEGER INDX(N) + REAL B(N) + + REAL SUM + INTEGER II, LL, I, J + + II = 0 + DO 20 I = 1, N + LL = INDX(I) + SUM = B(LL) + B(LL) = B(I) + IF (II .NE. 0) THEN + DO 10 J = II, I-1 + SUM = SUM - A(I,J) * B(J) + 10 CONTINUE + ELSE IF (SUM .NE. 0.) THEN + II = I + ENDIF + B(I) = SUM + 20 CONTINUE + + DO 40 I = N, 1, -1 + SUM = B(I) + IF (I .LT. N) THEN + DO 30 J = I+1, N + SUM = SUM - A(I,J) * B(J) + 30 CONTINUE + ENDIF + B(I) = SUM / A(I,I) + 40 CONTINUE + + RETURN + END diff --git a/pkg/utilities/nttools/stxtools/lubksd.f b/pkg/utilities/nttools/stxtools/lubksd.f new file mode 100644 index 00000000..04e17c6c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/lubksd.f @@ -0,0 +1,53 @@ + SUBROUTINE LUBKSD (A, N, NP, INDX, B) + +C Double-precision version of LUBKSB. +C +C Solves a matrix equation AX = B. Before using this routine you must +C call ludcmd to decompose the matrix A (in-place) into lower and upper +C triangular portions. The vector B is input to this routine, and the +C answer X is returned in B. +C +C double a(np,np) i: matrix returned by ludcmp +C int n i: logical size of a is n x n +C int np i: space allocated for a is np x np +C int indx(n) i: index returned by ludcmp +C double b(n) io: input b, output x in equation ax = b +C +C 1988 Oct 28 From Numerical Recipes. +C 1992 Sep 10 Rename from LUBKSB and convert to double precision. + + INTEGER N, NP + DOUBLE PRECISION A(NP,NP) + INTEGER INDX(N) + DOUBLE PRECISION B(N) + + DOUBLE PRECISION SUM + INTEGER II, LL, I, J + + II = 0 + DO 20 I = 1, N + LL = INDX(I) + SUM = B(LL) + B(LL) = B(I) + IF (II .NE. 0) THEN + DO 10 J = II, I-1 + SUM = SUM - A(I,J) * B(J) + 10 CONTINUE + ELSE IF (SUM .NE. 0.) THEN + II = I + ENDIF + B(I) = SUM + 20 CONTINUE + + DO 40 I = N, 1, -1 + SUM = B(I) + IF (I .LT. N) THEN + DO 30 J = I+1, N + SUM = SUM - A(I,J) * B(J) + 30 CONTINUE + ENDIF + B(I) = SUM / A(I,I) + 40 CONTINUE + + RETURN + END diff --git a/pkg/utilities/nttools/stxtools/ludcmd.x b/pkg/utilities/nttools/stxtools/ludcmd.x new file mode 100644 index 00000000..708a9df9 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/ludcmd.x @@ -0,0 +1,99 @@ +define TINY 1.d-20 + +# ludcmd -- lower-upper decomposition +# Double-precision version of ludcmp from Numerical Recipes. +# This differs from the Numerical Recipes version in the following ways: +# (1) the calling sequence also includes an ISTAT parameter, (2) memory +# is allocated instead of using the fixed array VV, and (3) double +# precision is used. +# This routine decomposes a matrix (in-place) into lower and upper +# triangular portions. Use lubksd to obtain a solution to A * X = B +# or to compute the inverse of the matrix A. +# If the matrix is singular, ISTAT is set to one. +# +# Phil Hodge, 28-Oct-1988 Subroutine copied from Numerical Recipes. +# Phil Hodge, 10-Sep-1992 Convert to double precision and rename from ludcmp. + +procedure ludcmd (a, n, np, indx, d, istat) + +double a[np,np] # io: input a, output decomposed a +int n # i: logical size of a is n x n +int np # i: space allocated for a +int indx[n] # o: index to be used by xt_lubksb +double d # o: +1 or -1 +int istat # o: OK if no problem; 1 if matrix is singular +#-- +pointer sp +pointer vv # scratch space +double aamax +double sum +double dum +int i, j, k +int imax + +begin + istat = OK # initial value + + call smark (sp) + call salloc (vv, n, TY_DOUBLE) + + d = 1.d0 + do i = 1, n { + aamax = 0.d0 + do j = 1, n + if (abs(a[i,j]) > aamax) + aamax = abs(a[i,j]) + if (aamax == 0.d0) { + istat = 1 + return + } + Memd[vv+i-1] = 1.d0 / aamax + } + do j = 1, n { + if (j > 1) { + do i = 1, j-1 { + sum = a[i,j] + if (i > 1) { + do k = 1, i-1 + sum = sum - a[i,k] * a[k,j] + a[i,j] = sum + } + } + } + aamax = 0.d0 + do i = j, n { + sum = a[i,j] + if (j > 1) { + do k = 1, j-1 + sum = sum - a[i,k] * a[k,j] + a[i,j] = sum + } + dum = Memd[vv+i-1] * abs[sum] + if (dum >= aamax) { + imax = i + aamax = dum + } + } + if (j != imax) { + do k = 1, n { + dum = a[imax,k] + a[imax,k] = a[j,k] + a[j,k] = dum + } + d = -d + Memd[vv+imax-1] = Memd[vv+j-1] + } + indx[j] = imax + if (j != n) { + if (a[j,j] == 0.d0) + a[j,j] = TINY + dum = 1.d0 / a[j,j] + do i = j+1, n + a[i,j] = a[i,j] * dum + } + } + if (a[n,n] == 0.d0) + a[n,n] = TINY + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/ludcmp.x b/pkg/utilities/nttools/stxtools/ludcmp.x new file mode 100644 index 00000000..cb2ce43d --- /dev/null +++ b/pkg/utilities/nttools/stxtools/ludcmp.x @@ -0,0 +1,87 @@ +define TINY 1.e-20 + +# ludcmp -- lower-upper decomposition +# This routine decomposes a matrix (in-place) into lower and upper +# triangular portions. This is the same as the Numerical Recipes version +# except that memory is allocated instead of using the fixed array VV. +# +# Phil Hodge, 28-Oct-1988 Subroutine copied from Numerical Recipes. + +procedure ludcmp (a, n, np, indx, d) + +real a[np,np] # io: input a, output decomposed a +int n # i: logical size of a is n x n +int np # i: space allocated for a +int indx[n] # o: index to be used by xt_lubksb +real d # o: +1 or -1 +#-- +pointer sp +pointer vv # scratch space +real aamax +real sum +real dum +int i, j, k +int imax + +begin + call smark (sp) + call salloc (vv, n, TY_REAL) + + d = 1. + do i = 1, n { + aamax = 0. + do j = 1, n + if (abs(a[i,j]) > aamax) + aamax = abs(a[i,j]) + if (aamax == 0.) + call error (0, "singular matrix") + Memr[vv+i-1] = 1. / aamax + } + do j = 1, n { + if (j > 1) { + do i = 1, j-1 { + sum = a[i,j] + if (i > 1) { + do k = 1, i-1 + sum = sum - a[i,k] * a[k,j] + a[i,j] = sum + } + } + } + aamax = 0. + do i = j, n { + sum = a[i,j] + if (j > 1) { + do k = 1, j-1 + sum = sum - a[i,k] * a[k,j] + a[i,j] = sum + } + dum = Memr[vv+i-1] * abs[sum] + if (dum >= aamax) { + imax = i + aamax = dum + } + } + if (j != imax) { + do k = 1, n { + dum = a[imax,k] + a[imax,k] = a[j,k] + a[j,k] = dum + } + d = -d + Memr[vv+imax-1] = Memr[vv+j-1] + } + indx[j] = imax + if (j != n) { + if (a[j,j] == 0.) + a[j,j] = TINY + dum = 1. / a[j,j] + do i = j+1, n + a[i,j] = a[i,j] * dum + } + } + if (a[n,n] == 0.) + a[n,n] = TINY + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/mkpkg b/pkg/utilities/nttools/stxtools/mkpkg new file mode 100644 index 00000000..218ad5f5 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/mkpkg @@ -0,0 +1,54 @@ +# Update the xtools library. +# Author: Phil Hodge, 16-NOV-1988 +# Modified to include similar.x : B.Simon 14-Mar-1989 +# Modified to include group template expansion routines : B.Simon 14-Feb-1990 +# Modified to include word.x and vex*.x : B.Simon 21-May-1990 +# Modified to include copyimg.x: B.Simon 02-Mar-1992 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + + +libpkg.a: + @od + @sp_util + @wcslab + changt.x + checkdim.x <imhdr.h> + cif.x "cif.h" + clgnone.x + copyimg.x <imhdr.h> + errxit.x + fbuild.x + fparse.x + grmimy.x <imhdr.h> + isblank.x <ctype.h> + lubksb.f + lubksd.f + ludcmd.x + ludcmp.x + postexit.x <clset.h> + savgol.x + sbuf.x "sbuf.h" + sgcone.x + similar.x + strjust.x <ctype.h> + stxgetcoord.x <imhdr.h> <mwset.h> <math.h> + tpbreak.x + tpclose.x "template.h" + tpcount.x "template.h" + tpfetch.x "template.h" + tpgroup.x <ctype.h> <imio.h> + tpimtype.x <ctype.h> "template.h" + tpopen.x "template.h" + tpparse.x <imio.h> + vexcompile.x <lexnum.h> <ctype.h> <fset.h> "vex.h" "vex.com" + vexeval.x "vex.h" + vexfree.x "vex.h" + vexfunc.x <mach.h> "vex.h" + vexstack.x "vex.h" + word.x + xtwcs.x <imhdr.h> <math.h> + ; diff --git a/pkg/utilities/nttools/stxtools/od/mkpkg b/pkg/utilities/nttools/stxtools/od/mkpkg new file mode 100644 index 00000000..a72fbad9 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/mkpkg @@ -0,0 +1,15 @@ +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + odget.x "od.h" + odmap.x <error.h> <imhdr.h> <imio.h> <tbset.h> "od.h" + odopep.x "od.h" + odpare.x + odput.x "od.h" + odsetn.x <imhdr.h> "od.h" + odunmp.x "od.h" + odwcsn.x <mwset.h> "od.h" + ; diff --git a/pkg/utilities/nttools/stxtools/od/od.h b/pkg/utilities/nttools/stxtools/od/od.h new file mode 100644 index 00000000..2070d551 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/od.h @@ -0,0 +1,32 @@ +#--------------------------------------------------------------------------- +.help od.h Feb93 source +.ih +NAME +od.h -- Include parameters for the 1D I/O data system. +.endhelp +#--------------------------------------------------------------------------- +#----- +# Below describes the structure and access to the OD descriptor. +define OD_FD Memi[$1] # The image/table descriptor +define OD_TYPE Memi[$1+1] # TABLE/IMAGE flag. +define OD_CD_PTR Memi[$1+2] # Table column descriptor. +define OD_CD Memi[OD_CD_PTR($1)+$2-1] +define OD_LEN Memi[$1+3] # Dimension of the data. +define OD_NGRP Memi[$1+4] # Number of groups in image. +define OD_GRP Memi[$1+5] # Current open group. +define OD_NAME_PTR Memi[$1+6] # Specified file name. +define OD_NAME Memc[OD_NAME_PTR($1)] +define OD_MW Memi[$1+7] # MWCS descriptor. +define OD_WL Memi[$1+8] # World-to-Logical transformation. +define OD_LW Memi[$1+9] # Logical-to-World transformation. +define OD_WSYS_PTR Memi[$1+10] # WCS system type. +define OD_WSYS Memc[OD_WSYS_PTR($1)] +define OD_OLD Memi[$1+11] # Template which opened this OD. +define OD_SZ_OD 12 # Size of structure. + +# The flag of what type of file we are dealing with. +define OD_TABLE 1 +define OD_IMAGE 2 +#--------------------------------------------------------------------------- +# End of od.h +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odget.x b/pkg/utilities/nttools/stxtools/od/odget.x new file mode 100644 index 00000000..013acc67 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odget.x @@ -0,0 +1,56 @@ +include "od.h" + +#--------------------------------------------------------------------------- +.help od_get Feb93 source +.ih +NAME +od_get -- Retrieve data from file. +.ih +USAGE +.nf +call od_getd (od, data) +.fi +.ih +ARGUMENTS +.ls od (pointer :input) +The OD I/O descriptor. +.le +.ls data (double[ARB] :output) +The data from the OD file. +.le +.endhelp +#--------------------------------------------------------------------------- +procedure od_get (od, data) + +pointer od # I: The OD I/O descriptor. +double data[ARB] # O: The data. + +pointer null # Null flag array for table IO. + +# Functions +pointer imgl1d() + +errchk gf_opengr, imgl1d, malloc, mfree, tbcgtd + +begin + # Check if a file is actually opened. If not, do nothing. + if (od != NULL) { + + # Get data depending on file type. + switch (OD_TYPE(od)) { + case OD_TABLE: + call malloc (null, OD_LEN(od), TY_BOOL) + call tbcgtd (OD_FD(od), OD_CD(od,OD_GRP(od)), data, Memb[null], + 1, OD_LEN(od)) + call mfree (null, TY_BOOL) + + case OD_IMAGE: + + # Retrieve the data. + call amovd (Memd[imgl1d(OD_FD(od))], data, OD_LEN(od)) + } + } +end +#--------------------------------------------------------------------------- +# End of od_get +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odmap.x b/pkg/utilities/nttools/stxtools/od/odmap.x new file mode 100644 index 00000000..f41ad5e1 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odmap.x @@ -0,0 +1,250 @@ +include <error.h> +include <imhdr.h> +include <imio.h> +include <tbset.h> +include "od.h" + +# Define the default column number to retrieve table data from +define DEFAULT_COL 1 + +#--------------------------------------------------------------------------- +.help od_map Feb93 source +.ih +NAME +.nf +od_map -- Open a file as either an image or table. + +od_image_map -- Internal: Map an image. +od_table_map -- Internal: Map a table. +.fi +.ih +USAGE +.nf +od = od_map (name, mode, old) + +call od_image_map (name, od) +call od_table_map (name, mode, od) +.fi +.ih +ARGUMENTS +.ls name (char[ARB] :input) +The name of the file to open. +.le +.ls mode (int :input) +The access mode to open the file in. Same as the standard IRAF open +modes. +.le +.ls old (pointer :input) +If creating a new file, use this as a template. If NULL, no template will +be assumed. This is the OD descriptor, not an IMIO or TABLE descriptor. +.le +.ls od (pointer :input) +The OD I/O descriptor. +.le +.ih +RETURNS +An od i/o file descriptor containing the image/table descriptor, a flag +indicating whether it is an image or table, and, if a table, the column +descriptor to retrieve the data from. +.ih +DESCRIPTION +This provides a common interface to retrieve one dimensional data from +either an image or a table. This is vary basic and is not intended to +handle a full i/o interface. Just need to open, close, and read data. + +Added some syntax to the table name specification. We will allow the +column names/numbers to be specified in a "section" notation. An +example: + +.nf + tablename[columnname1,...] +.fi + +where columnnameX are either names or numbers. If no column +specification is used, then it is assumed all columns of the table are +to be used and will be considered with the appropriate "group" of +multigroup input. +.endhelp +#--------------------------------------------------------------------------- +pointer procedure od_map(name, mode, old) + +char name[ARB] # I: The file name to open. +int mode # I: The mode to open the file in. +pointer old # I: Template OD I/O descriptor as template. + +# Declarations. +pointer od # OD I/O descriptor. +pointer sp # Stack Pointer. +pointer sx # Generic string. + +# Function prototypes +pointer immap() + +errchk malloc, od_image_map, od_table_map + +begin + call smark (sp) + call salloc (sx, SZ_LINE, TY_CHAR) + + # Allocate the od i/o descriptor. + call malloc (od, OD_SZ_OD, TY_STRUCT) + call malloc (OD_NAME_PTR(od), SZ_LINE, TY_CHAR) + call malloc (OD_WSYS_PTR(od), SZ_LINE, TY_CHAR) + + # If an old descriptor is given, base what open occurs on + # its type. + OD_OLD(od) = old + if (old != NULL) + switch (OD_TYPE(old)) { + case OD_IMAGE: + OD_FD(od) = immap (name, mode, OD_FD(old)) + call od_image_map (name, od) + case OD_TABLE: + call od_table_map (name, mode, OD_FD(old), od) + } + + # Else, just open up that data file. If the image call doesn't fail, + # then assume its an image. + else ifnoerr (OD_FD(od) = immap (name, mode, NULL)) + call od_image_map (name, od) + + # If it cannot be opened as a table, try changing the extension. + # If that fails, then give it up. + else iferr (call od_table_map (name, mode, NULL, od)) { + call change_ext (name, "c1h", Memc[sx], SZ_LINE) + iferr (OD_FD(od) = immap (Memc[sx], mode, NULL)) { + call erract (EA_ERROR) + } + call od_image_map (Memc[sx], od) + } + + # That's all folks. + call sfree (sp) + return (od) +end +#--------------------------------------------------------------------------- +# End of od_map +#--------------------------------------------------------------------------- +procedure od_image_map (name, od) + +char name[ARB] # I: Full specified name. +pointer od # I: OD I/O descriptor. + +# Declarations. +int i # Generic. + +pointer sp # Stack pointer. +pointer sx + +begin + call smark (sp) + call salloc (sx, SZ_LINE, TY_CHAR) + + # Fill the OD I/O descriptor. + OD_TYPE(od) = OD_IMAGE + OD_CD_PTR(od) = NULL + OD_LEN(od) = IM_LEN(OD_FD(od),1) + OD_NGRP(od) = max(1,IM_CLSIZE(OD_FD(od))) + call strcpy (IM_HDRFILE(OD_FD(od)), OD_NAME(od), SZ_LINE) + + # See whether a specific group was opened. + call fparse (name, Memc[sx], SZ_LINE, Memc[sx], SZ_LINE, Memc[sx], + SZ_LINE, OD_GRP(od), i, Memc[sx], SZ_LINE, Memc[sx], + SZ_LINE) + if (OD_GRP(od) > 0) + OD_NGRP(od) = 1 + else + OD_GRP(od) = 1 + + # Get world coordinate information. + call od_wcs_open (od) + + # That's all folks. + call sfree (sp) +end +#--------------------------------------------------------------------------- +# End of od_image_map +#--------------------------------------------------------------------------- +procedure od_table_map (name, mode, old, od) + +char name[ARB] # I: The specified file name. +int mode # I: The file access mode. +pointer old # I: Original OD descriptor. +pointer od # I: The OD I/O descriptor. + +# Declarations. +int i, j, k # Generic. +int ic # Pointer into section list. + +pointer colname # Current column name. +pointer section # Section specification. +pointer sp # Stack pointer. +pointer sx # Generic. + +# Functions. +int ctoi(), strlen(), word_count(), word_fetch(), tbpsta() +pointer tbcnum(), tbtopn() + +errchk tbcnum, tbpsta, tbtopn, word_count, word_fetch + +begin + call smark (sp) + call salloc (colname, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + call salloc (sx, SZ_LINE, TY_CHAR) + + # Set what type of file. + OD_TYPE(od) = OD_TABLE + + # Get the base filename and section. + call od_parse (name, OD_NAME(od), SZ_LINE, Memc[section], SZ_LINE) + + # Open up and get some parameters. + OD_FD(od) = tbtopn (OD_NAME(od), mode, old) + OD_LEN(od) = tbpsta (OD_FD(od), TBL_NROWS) + OD_GRP(od) = 1 + OD_MW(od) = NULL + OD_WL(od) = NULL + OD_LW(od) = NULL + + # Now retrieve the columns. If no columns are specified, then use + # all the columns. + if (strlen (Memc[section]) <= 0) { + OD_NGRP(od) = tbpsta (OD_FD(od), TBL_NCOLS) + call malloc (OD_CD_PTR(od), OD_NGRP(od), TY_POINTER) + do i = 1, OD_NGRP(od) { + OD_CD(od,i) = tbcnum (OD_FD(od), i) + if (OD_CD(od,i) == NULL) { + call sprintf (Memc[sx], SZ_LINE, "Cannot open column %d in table %s") + call pargi (i) + call pargstr (OD_NAME(od)) + call error (1, Memc[sx]) + } + } + } else { + OD_NGRP(od) = word_count (Memc[section]) + call malloc (OD_CD_PTR(od), OD_NGRP(od), TY_POINTER) + i = 0 + ic = 1 + while (word_fetch (Memc[section], ic, Memc[colname], SZ_LINE) > 0) { + i = i + 1 + k = 1 + if (ctoi (Memc[colname], k, j) > 0) + OD_CD(od,i) = tbcnum (OD_FD(od), j) + else + call tbcfnd (OD_FD(od), Memc[colname], OD_CD(od,i), 1) + } + if (OD_CD(od,i) == NULL) { + call sprintf (Memc[sx], SZ_LINE, "Cannot open column %s in table %s") + call pargstr (Memc[colname]) + call pargstr (OD_NAME(od)) + call error (1, Memc[sx]) + } + } + + # That's all folks. + call sfree (sp) +end +#--------------------------------------------------------------------------- +# End of od_table_map +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odopep.x b/pkg/utilities/nttools/stxtools/od/odopep.x new file mode 100644 index 00000000..cd757f93 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odopep.x @@ -0,0 +1,56 @@ +include "od.h" + +#--------------------------------------------------------------------------- +.help od_open_group 11Jul95 source +.ih +NAME +od_open_group -- Open another "group" of the file +.ih +USAGE +call od_open_group (od, group) +.fi +.ih +ARGUMENTS +.ls od (pointer :input) +The OD I/O descriptor. +.le +.ls group (int :input) +The "group" to open. For tables, this means the column number to open. +.le +.endhelp +#--------------------------------------------------------------------------- +procedure od_open_group (od, group) + +pointer od # I: The 1D descriptor. +int group # I: The group to open. + +# Misc. +real rx # Generic. + +errchk gf_opengr, mw_close, od_wcs_open + +begin + switch (OD_TYPE(od)) { + case OD_TABLE: + if (group > OD_NGRP(od)) + call error (1, "Attempt to open non-existant column") + OD_GRP(od) = group + + case OD_IMAGE: + if (group > OD_NGRP(od)) + call error (1, "Attempt to open non-existant group") + + call mw_close (OD_MW(od)) + + if (OD_OLD(od) != NULL) + call gf_opengr (OD_FD(od), group, rx, rx, OD_FD(OD_OLD(od))) + else + call gf_opengr (OD_FD(od), group, rx, rx, NULL) + OD_GRP(od) = group + + call od_wcs_open (od) + } +end +#--------------------------------------------------------------------------- +# End of od_open_group +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odpare.x b/pkg/utilities/nttools/stxtools/od/odpare.x new file mode 100644 index 00000000..0bea6112 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odpare.x @@ -0,0 +1,84 @@ +#--------------------------------------------------------------------------- +.help od_parse Feb93 source +.ih +NAME +od_parse -- Parse a section for column names. +.ih +USAGE +call od_parse +.ih +ARGUMENTS +.ih +DESCRIPTION +Taken from Bernie Simon's aspare without any modifications. +.endhelp +#--------------------------------------------------------------------------- +#* HISTORY * +#* D.Ball 18-Apr-88 original +#* B.Simon 06-Aug-92 removed code which deletes commas + +# OD_PARSE -- Parse a file name specification into file name and section fields +# +# Syntax: filename[section] +# +# The [ character must be escaped to be included in the filename. +# This syntax is similar to the image section syntax in imio, but +# is intended to extract variable names or numbers, column names, etc. +# for the Astronomical Survival analysis suite of programs. +# The section field is returned as a string with no leading or trailing +# brackets. + +procedure od_parse (filespec, file, sz_file, section, sz_section) + +char filespec[ARB] # i: full file specification +char file[sz_file] # o: receives file name +int sz_file # i: max chars in file name +char section[sz_section] # o: receives section +int sz_section # i: max chars in section name +#-- +int ch, ip, op, right + +int strlen() + +begin + ip = 1 + op = 1 + + # Extract file name. The first (unescaped) [ marks the start of + # the section field. + + for (ch=filespec[ip]; ch != EOS && ch != '['; ch=filespec[ip]) { + if (ch == '\\' && filespec[ip+1] == '[') { + file[op] = '\\' + op = op + 1 + file[op] = '[' + ip = ip + 1 + } else + file[op] = ch + + op = min (sz_file, op + 1) + ip = ip + 1 + } + + file[op] = EOS + section[1] = EOS + + if (ch == EOS) + return + + # If we have a [...] field, copy the section string, + # removing the brackets, and any commas used as delimiters. + + # Eliminate the leading "[" + ip = ip + 1 + call strcpy (filespec[ip], section, sz_section) + + # Remove the trailing "]" + right = strlen (section) + if (section[right] == ']') + section[right] = EOS + +end +#--------------------------------------------------------------------------- +# End of od_parse +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odput.x b/pkg/utilities/nttools/stxtools/od/odput.x new file mode 100644 index 00000000..d02f59a5 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odput.x @@ -0,0 +1,50 @@ +include "od.h" + +#--------------------------------------------------------------------------- +.help od_put Feb93 source +.ih +NAME +od_put -- Put the data in the file. +.ih +USAGE +.nf +call od_putd (od, data) +.fi +.ih +ARGUMENTS +.ls od (input: pointer) +The OD I/O descriptor. +.le +.ls data (input: double[ARB]) +The data to put in the OD file. +.le +.endhelp +#--------------------------------------------------------------------------- +procedure od_put (od, data) + +pointer od # I: The OD I/O descriptor. +double data[ARB] # I: The data. + +# Functions +pointer impl1d() + +errchk impl1d, tbcptd + +begin + # Check if a file is actually opened. If not, do nothing. + if (od != NULL) { + + # Get data depending on file type. + switch (OD_TYPE(od)) { + case OD_TABLE: + call tbcptd (OD_FD(od), OD_CD(od,OD_GRP(od)), data, + 1, OD_LEN(od)) + + case OD_IMAGE: + call amovd (data, Memd[impl1d (OD_FD(od))], OD_LEN(od)) + } + } +end +#--------------------------------------------------------------------------- +# End of od_put +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odsetn.x b/pkg/utilities/nttools/stxtools/od/odsetn.x new file mode 100644 index 00000000..3abf97f7 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odsetn.x @@ -0,0 +1,29 @@ +include <imhdr.h> +include "od.h" + +#--------------------------------------------------------------------------- +.help od_set_len Jun93 source +.ih +NAME +od_set_len -- Set the length of data. +.ih +DESCRIPTION +This sets how much data is read/written from the OD file. For images, +the dimensionality is changed. For tables, it just changes how much +is read/written; nothing is physically changed about the table. +.endhelp +#--------------------------------------------------------------------------- +procedure od_set_len (od, len) + +pointer od # I: OD descriptor. +int len # I: New length. + +begin + OD_LEN(od) = len + if (OD_TYPE(od) == OD_IMAGE) { + IM_LEN(OD_FD(od),1) = len + } +end +#--------------------------------------------------------------------------- +# End of od_set_len +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odunmp.x b/pkg/utilities/nttools/stxtools/od/odunmp.x new file mode 100644 index 00000000..e776ecd7 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odunmp.x @@ -0,0 +1,44 @@ +include "od.h" + +#--------------------------------------------------------------------------- +.help od_unmap Feb93 source +.ih +NAME +od_unmap -- Close the 1D image. +.ih +USAGE +call od_unmap (od) +.ih +ARGUMENTS +.ls od (input/output: pointer) +The OD I/O descriptor. On return, the value will be NULL. +.le +.endhelp +#--------------------------------------------------------------------------- +procedure od_unmap (od) + +pointer od # I: The OD I/O descriptor. + +errchk tbtclo, imunmap, mfree + +begin + if (od != NULL) { + switch (OD_TYPE(od)) { + case OD_TABLE: + call tbtclo (OD_FD(od)) + call mfree (OD_CD_PTR(od), TY_POINTER) + case OD_IMAGE: + call mw_ctfree (OD_WL(od)) + call mw_ctfree (OD_LW(od)) + call mw_close (OD_MW(od)) + call imunmap (OD_FD(od)) + } + + call mfree (OD_WSYS_PTR(od), TY_CHAR) + call mfree (OD_NAME_PTR(od), TY_CHAR) + call mfree (od, TY_STRUCT) + } +end +#--------------------------------------------------------------------------- +# End of od_unmap +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odwcsn.x b/pkg/utilities/nttools/stxtools/od/odwcsn.x new file mode 100644 index 00000000..e79a4154 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odwcsn.x @@ -0,0 +1,39 @@ +include <mwset.h> +include "od.h" + +#--------------------------------------------------------------------------- +.help od_wcs_open May93 source +.ih +NAME +od_wcs_open -- Open the WCS information for an image. +.endhelp +#--------------------------------------------------------------------------- +procedure od_wcs_open (od) + +pointer od # I: Image descriptor. + +pointer mw_openim() +pointer mw_sctran() +bool streq() + +begin + if (OD_TYPE(od) == OD_IMAGE) { + OD_MW(od) = mw_openim (OD_FD(od)) + call mw_gwattrs (OD_MW(od), 0, "system", OD_WSYS(od), SZ_LINE) + if (streq ("multispec", OD_WSYS(od))) { + call mw_seti (OD_MW(od), MW_USEAXMAP, NO) + OD_WL(od) = mw_sctran (OD_MW(od), "multispec", "logical", 3b) + OD_LW(od) = mw_sctran (OD_MW(od), "logical", "multispec", 3b) + } else { + OD_WL(od) = mw_sctran (OD_MW(od), "world", "logical", 1) + OD_LW(od) = mw_sctran (OD_MW(od), "logical", "world", 1) + } + } else { + OD_MW(od) = NULL + OD_LW(od) = NULL + OD_WL(od) = NULL + } +end +#--------------------------------------------------------------------------- +# End of od_wcs_open +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/postexit.x b/pkg/utilities/nttools/stxtools/postexit.x new file mode 100644 index 00000000..ebad32f9 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/postexit.x @@ -0,0 +1,52 @@ +include <clset.h> + +# POST_EXIT_HANDLER -- Post an error handler that exits with an error code + +# The standard behavior of an iraf program is to exit with an error code +# of zero regardless of whether program execution is halted with an error. +# This behavior complicates control of tasks by user scripts. To change this +# behavor, this procedure posts an error handler that exits the program with +# its error code set to the value passed to the error procedure. The exit +# procedure is only called of the program terminates with a non-zero error +# status and the program is being run at the host level. The latter +# restriction is in place because exiting a program running under the iraf +# command language (cl) hangs the command language. Since error handlers +# a run in the order that they are posted, this procedure should be called +# after any other error handlers you may have in your program. +# +# Nelson Zarate 30-Nov-95 original + +procedure post_exit_handler () + +#-- +extern exit_handler() +int clstati() + +begin + # Only post the exit handler if the task is being run in host mode + + if (clstati(CL_PRTYPE) == PR_HOST) + call onerror(exit_handler) +end + +# EXIT_HANDLER -- Error handler that exits the program, setting the error code + +procedure exit_handler (status) + +int status # i: program exit status +#-- + +begin + # Only take exit if error status is non-zero (not OK) + + if (status != OK) { + # Must clean up file i/o first + # The OK flag flushes the buffers + + call fio_cleanup (OK) + + # Take the error exit with the specified status + + call errxit (status) + } +end diff --git a/pkg/utilities/nttools/stxtools/savgol.x b/pkg/utilities/nttools/stxtools/savgol.x new file mode 100644 index 00000000..48958ede --- /dev/null +++ b/pkg/utilities/nttools/stxtools/savgol.x @@ -0,0 +1,140 @@ +# Define some memory management. +define A Memd[a+((($2)-1)*(m+1))+($1)-1] +define B Memd[b+($1)-1] + +#--------------------------------------------------------------------------- +.help savgol Jun93 source +.ih +NAME +savgol -- Create a kernel for Savitzky-Golay smoothing. +.ih +USAGE +call savgol (c, np, nl, nr, ld, m) +.ih +ARGUMENTS +.ls c (O: double[np]) +The smoothing kernel in "wrap-around" order. See discussion for +details. +.le +.ls np (I: int) +The number of points allocated in the array represented by the "c" +argument. +.le +.ls nl (I: int) +Size of the kernel "to the left" of the central point. See discussion +for more details. +.le +.ls nr (I: int) +Size of the kernel "to the right" of the central point. See discussion +for more details. +.le +.ls ld (I: int) +Order of the derivative desired. Should be 0 for smoothing, higher +for smoothed versions of the specified derivative. +.le +.ls m (I: int) +Order of the smoothing polynomial. Should be 0 or 1 for standard +"boxcar" or "moving window" averaging. +.le +.ih +DISCUSSION +For an introduction to Savitzky-Golay filtering, see: + +.nf + Press, Teukolsky, Vetterling, & Falnnery, "Numeric Recipies: + The Art of Scientifitc Computing, Second Edition", Cambridge, + 1992. +.fi + +This routine returns the set of Savitzky-Golay smoothing coefficients +given the size, order of smoothing polynomial, and derivative to +return. The coefficients are returned in "wrap-around" order. Thus, +if the smoothing coefficients are C[-nl]...C[0]...C[nr], they are +returned in the array, c[i], as follows: + +.nf + c[1], c[2], c[3], ..., c[nl+1],c[nl+2],...,c[np-1],c[np] + + C[0], C[-1], C[-2],..., C[-nl], C[nr], ...,C[2], C[1] +.fi + +A code fragment to transform the array c[i] to the orginal order, +k[i], is: + +.nf + do i = 1, nl+1 + k[i] = c[nl+2-i] + do i = 1, nr + k[nl+1+i] = c[np+1-i] +.fi + +Array k[i], is now suitable for routines such as the IRAF VOPS routine +acnvrd. +.endhelp +#--------------------------------------------------------------------------- +procedure savgol (c, np, nl, nr, ld, m) + +double c[np] # O: The kernel. +int np # I: Size of the smoothing kernel. +int nl # I: Points to the left of center. +int nr # I: Points to the right of center. +int ld # I: Order of derivative to return. +int m # I: Order of the smoothing polynomial. + +int imj, ipj, j, k, kk, mm, ix +double d, fac, sum +pointer indx, a, b, sp +int shifti() + +begin + call smark (sp) + # Check input parameters. + if (np < nl+nr+1 || nl < 0 || nr < 0 || ld > m || nl+nr < m) + call error (1, "savgol: invalid inputs") + + # Allocate memory. + call salloc (indx, m+1, TY_INT) + call salloc (a, (m+1)**2, TY_DOUBLE) + call salloc (b, m+1, TY_DOUBLE) + + # Do it. + ipj = shifti (m, 1) + do ipj = 0, shifti (m, 1) { + if (ipj != 0) + sum = 0.d0 + else + sum = 1.d0 + do k = 1, nr + sum = sum + k**ipj + do k = 1, nl + sum = sum + (-k)**ipj + mm = min (ipj, 2*m-ipj) + do imj = -mm, mm, 2 + A(1+(ipj-imj)/2,1+(ipj+imj)/2) = sum + } + call ludcmd (Memd[a], m+1, m+1, Memi[indx], d, ix) + if (ix != OK) + call error (1, "savgol: singular matrix") + do j = 1, m+1 + B(j) = 0.d0 + B(ld+1) = 1.d0; + call lubksd (Memd[a], m+1, m+1, Memi[indx], Memd[b]) + do kk = 1, np + c[kk] = 0.d0 + do k = -nl, nr { + sum = B(1) + fac = 1.d0 + do mm = 1, m { + fac = fac * k + sum = sum + B(mm+1) * fac + } + kk = mod (np - k, np) + 1 + c[kk] = sum + } + + # That's all folks. + call sfree (sp) +end +#--------------------------------------------------------------------------- +# End of savgol +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sbuf.h b/pkg/utilities/nttools/stxtools/sbuf.h new file mode 100644 index 00000000..cda82d9b --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sbuf.h @@ -0,0 +1,15 @@ +#--------------------------------------------------------------------------- +.help sbuf.h Feb93 source +.ih +NAME +sbuf.h -- Memory structure for long strings. +.endhelp +#--------------------------------------------------------------------------- +define SB_LEN Memi[$1] # Current length of string. +define SB_MAXLEN Memi[$1+1] # Current maximum size of buffer. +define SB_PTR Memi[$1+2] # Pointer to the string array. +define SB_BUF Memc[SB_PTR($1)+$2] +define SB_SZ_SB 3 # Size of memory structure. +#--------------------------------------------------------------------------- +# End of sbuf.h +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sbuf.x b/pkg/utilities/nttools/stxtools/sbuf.x new file mode 100644 index 00000000..a5bead52 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sbuf.x @@ -0,0 +1,110 @@ +include "sbuf.h" + +#--------------------------------------------------------------------------- +.help sbuf Mar93 source +.ih +NAME +.nf +sb_open -- Open an sbuf. +sb_cat -- Add a string to the end of sbuf. +sb_close -- Close an sbuf. +sb_string -- Get the string to an sbuf. +.fi +.ih +USAGE +.nf +sb = sb_open() +call sb_cat (sb, str) +call sb_close (sb) +str_ptr = sb_string (sb) +.fi +.ih +ARGUMENTS +.ls sb (pointer :input/output) +The string buffer descriptor. +.le +.ls str (char[ARB] :input) +The string to append to the string buffer. +.le +.ls str_ptr (pointer :output) +A pointer to a string array containing the contents of the string buffer. +When done, the user is required to deallocate this memory using the call +"call mfree (str_ptr, TY_CHAR)". +.le +.ih +DISCUSSION +This interface allows one to handle arbitrarily long strings without +having to worry about the memory management. + +There may be other utility routines to add; feel free to do so. +.endhelp +#--------------------------------------------------------------------------- +pointer procedure sb_open + +pointer sb # The sbuf pointer + +errchk malloc + +begin + call malloc (sb, SB_SZ_SB, TY_STRUCT) + call malloc (SB_PTR(sb), SZ_LINE, TY_CHAR) + SB_LEN(sb) = 0 + SB_MAXLEN(sb) = SZ_LINE + + return (sb) +end +#--------------------------------------------------------------------------- +# End of sb_open +#--------------------------------------------------------------------------- +procedure sb_close (sb) + +pointer sb # IO: The sbuf descriptor, NULL on exit. + +errchk mfree + +begin + if (sb != NULL) { + call mfree (SB_PTR(sb), TY_CHAR) + call mfree (sb, TY_STRUCT) + } +end +#--------------------------------------------------------------------------- +# End of sb_close +#--------------------------------------------------------------------------- +pointer procedure sb_string (sb) + +pointer sb # I: The sbuf descriptor. + +pointer str # New string pointer. + +begin + call malloc (str, SB_LEN(sb), TY_CHAR) + call strcpy (SB_BUF(sb,0), Memc[str], SB_LEN(sb)) + + return (str) +end +#--------------------------------------------------------------------------- +# End of sb_string +#--------------------------------------------------------------------------- +procedure sb_cat (sb, str) + +pointer sb # I: The sbuf descriptor. +char str[ARB] # I: The string to concatenate. + +int i, strlen() # Length of input string. + +errchk realloc + +begin + i = strlen (str) + if (i + SB_LEN(sb) >= SB_MAXLEN(sb)) { + SB_MAXLEN(sb) = SB_MAXLEN(sb) + i + SZ_LINE + call realloc (SB_PTR(sb), SB_MAXLEN(sb), TY_CHAR) + } + + call strcpy (str, SB_BUF(sb,SB_LEN(sb)), i) + SB_LEN(sb) = SB_LEN(sb) + i +end +#--------------------------------------------------------------------------- +# End of sb_cat +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sgcone.x b/pkg/utilities/nttools/stxtools/sgcone.x new file mode 100644 index 00000000..074f4089 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sgcone.x @@ -0,0 +1,94 @@ +#--------------------------------------------------------------------------- +.help sg_convolve Jun93 source +.ih +NAME +sg_convolve -- Convolve an array using Savitzky-Golay filter. +.ih +USAGE +call sg_convolve (size, order, in, out, n) +.ih +ARGUMENTS +.ls size (I: int) +The full size of the smoothing kernel. If less than or equal to 1, +then no convolving takes place. +.le +.ls order (I: int) +The order of the smoothing polynomial. For normal "boxcar" smoothing, +this should be 0 or 1. Greater values preserve higher order terms in the +original data. Larger sizes are needed for this to be effective. +.le +.ls in (I: double[n]) +The data array to be convolved. +.le +.ls out (O: double[n]) +The convolved array. May be the same as the input array. +.le +.ih +DESCRIPTION +The routine, savgol, is used to calculate a Savitsky-Golay convolving +kernel. This kernel is then applied, using standard routines, to the +input data. See the routine savgol for more information. +.ih +SEE ALSO +savgol +.endhelp +#--------------------------------------------------------------------------- +procedure sg_convolve (size, order, in, out, n) + +int size # I: The size of the filter. +int order # I: The order to preserve while filtering. +double in[n] # I: Data to be convolved. +double out[n] # O: The convolved data. +int n # I: Length of the arrays. + +# Kernel parameters. +int half # Half size of kernel. +int isize # Odd size of kernel. +pointer k, kx # The kernel in real/double-wrap versions. + +# Misc. +pointer adx # Generic double array. +int i # Generic. +pointer sp # Stack pointer. + +begin + call smark (sp) + + # Fix the kernel size to be odd. + half = size / 2 + isize = half * 2 + 1 + + # Make sure there is something to convolve. If not, just copy and + # run. + if (isize <= 1) + call amovd (in, out, n) + else { + call salloc (k, isize, TY_REAL) + call salloc (kx, isize, TY_DOUBLE) + call salloc (adx, n+isize, TY_DOUBLE) + + # Compute the kernel. + call savgol (Memd[kx], isize, half, half, 0, order) + do i = 0, half + Memr[k+i] = Memd[kx+half-i] + do i = 0, half-1 + Memr[k+half+i+1] = Memd[kx+isize -i-1] + + # Put the data in the extended array and pad the ends as + # constants. + call amovd (in, Memd[adx+half], n) + do i = 1, half { + Memd[adx+half-i] = in[1] + Memd[adx+half+n+i-1] = in[n] + } + + # Filter it. + call acnvrd (Memd[adx], out, n, Memr[k], isize) + } + + # That's all folks. + call sfree (sp) +end +#--------------------------------------------------------------------------- +# End of sg_convolve +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/similar.x b/pkg/utilities/nttools/stxtools/similar.x new file mode 100644 index 00000000..a7b1a644 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/similar.x @@ -0,0 +1,127 @@ +define SZ_STACK 25 + +# SIMILAR -- Return a score base on the similarity between two strings + +# This procedure returns a number representing the similarity between +# two strings. The number is computed by finding the combined length of +# all the common substrings between the two strings, normalized to a value +# between zero and one hundred. +# +# B.Simon 13-Mar-89 Original + +int procedure similar (str1, str2) + +char str1[ARB] # i: First string +char str2[ARB] # i: Second string +#-- +int score, istack, len1, len2, maxch, ic, nc +pointer stack[4,SZ_STACK] +pointer sp, word1, word2, s1, s2 +pointer start1, end1, start2, end2, newstart1, newend1, newstart2, newend2 + +string overflow "Stack overflow in procedure similar" + +int strlen() + +begin + # If either string is zero length, return zero as score + + score = 0 + len1 = strlen (str1) + len2 = strlen (str2) + if (len1 == 0 || len2 == 0) + return (score) + + # Compare the lower case version of the strings + + call smark (sp) + call salloc (word1, len1, TY_CHAR) + call salloc (word2, len2, TY_CHAR) + + call strcpy (str1, Memc[word1], len1) + call strlwr (Memc[word1]) + + call strcpy (str2, Memc[word2], len2) + call strlwr (Memc[word2]) + + # The first substrings to compare are the entire strings + + istack = 1 + stack[1,istack] = word1 + stack[2,istack] = word1 + len1 - 1 + stack[3,istack] = word2 + stack[4,istack] = word2 + len2 - 1 + + # While there are more substrings on the stack + + while (istack > 0) { + + # Find the longest match between the substrings + + maxch = 0 + start1 = stack[1,istack] + end1 = stack[2,istack] + start2 = stack[3,istack] + end2 = stack[4,istack] + + for (s1 = start1; s1 <= end1 - maxch; s1 = s1 + 1) { + + nc = end1 - s1 + + for (s2 = start2; s2 <= end2 - maxch; s2 = s2 + 1) { + + if (Memc[s1] == Memc[s2]) { + + # Compute the length of the match + + for (ic = 1; + ic <= nc && Memc[s1+ic] == Memc[s2+ic]; + ic = ic + 1) + ; + + # If this is the longest match so far, save + # the length and start and end points + + if (ic > maxch) { + maxch = ic + newstart1 = s1 + newstart2 = s2 + newend1 = s1 + ic - 1 + newend2 = s2 + ic - 1 + } + s2 = s2 + ic - 1 + } + } + } + + # Pop the stack and push the new substings on the stack + + istack = istack - 1 + if (maxch > 0) { + score = score + 2 * maxch + + if (start1 != newstart1 && start2 != newstart2) { + if (istack == SZ_STACK) + call error (1, overflow) + istack = istack + 1 + stack[1,istack] = start1 + stack[2,istack] = newstart1 - 1 + stack[3,istack] = start2 + stack[4,istack] = newstart2 - 1 + } + + if (end1 != newend1 && end2 != newend2) { + if (istack == SZ_STACK) + call error (1, overflow) + istack = istack + 1 + stack[1,istack] = newend1 + 1 + stack[2,istack] = end1 + stack[3,istack] = newend2 + 1 + stack[4,istack] = end2 + } + } + } + + call sfree (sp) + return (100 * score / (len1 + len2)) +end diff --git a/pkg/utilities/nttools/stxtools/sp_util/mkpkg b/pkg/utilities/nttools/stxtools/sp_util/mkpkg new file mode 100644 index 00000000..52a93adb --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/mkpkg @@ -0,0 +1,16 @@ +# Make the wcslab package + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + spchag.x + spdise.x + spmapt.x <gset.h> + sprote.x <math.h> + spstry.x + sptras.x + spw2ld.x + spwcss.x <ctype.h> diff --git a/pkg/utilities/nttools/stxtools/sp_util/spchag.x b/pkg/utilities/nttools/stxtools/sp_util/spchag.x new file mode 100644 index 00000000..f6292a4e --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spchag.x @@ -0,0 +1,64 @@ +# sp_change_string - Replace a string with the indicated string. +# +# History +# 1Apr91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_change_string( input, old, new, output, max ) + +char input[ARB] # I: The input string. +char old[ARB] # I: The string segment to be replaced. +char new[ARB] # I: The string to replace the old with. +char output[ARB] # O: The modified input string. +int max # I: The maximun length of the output string. + +# Declarations. +int after # Next character position after match. +int first # First character position of matched string. +int ilen # Length of input. +int ip # Pointer into input. +int last # Last character position of matched string. +int old_len # Length of old. +int op # Pointer into output. + +# Function declarations. +int gstrcpy(), strlen(), gstrmatch() + +begin + + # Initialize the string pointers. + ip = 1 + op = 1 + ilen = strlen( input ) + old_len = strlen( old ) + + # Keep going until either the input string has been completely copied + # or the output string is full. + while( ip < ( ilen + 1 ) && op < ( max + 1 ) ) { + + # Search for the old string. + after = gstrmatch( input[ip], old, first, last ) + + # If the string is not found, then copy the rest of the input to the + # output. + if( after == 0 ) { + call strcpy( input[ip], output[op], max - op + 1 ) + ip = ilen + 1 + } + + # The old string is found, copy the input up to the old string + # and replace the old string. + else { + first = min( first - 1, max - op + 1 ) + call sp_strncpy( input[ip], first, output[op] ) + ip = ip + last + op = op + first + op = op + gstrcpy( new, output[op], max - op + 1 ) + } + + } + +end +#--------------------------------------------------------------------------- +# End of sp_change_string +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/spdise.x b/pkg/utilities/nttools/stxtools/sp_util/spdise.x new file mode 100644 index 00000000..9985c790 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spdise.x @@ -0,0 +1,44 @@ +# sp_distanced - Determine the distance between two points. +# +# History +# 4Dec90 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +double procedure sp_distanced( x1, y1, x2, y2 ) + +double x1, y1, x2, y2 + +double a, b + +begin + + a = x1 - x2 + b = y1 - y2 + return( sqrt( ( a * a ) + ( b * b ) ) ) + +end +#--------------------------------------------------------------------------- +# End of sp_distanced +#--------------------------------------------------------------------------- +# sp_distancer - Determine the distance between two points. +# +# History +# 4Dec90 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +real procedure sp_distancer( x1, y1, x2, y2 ) + +real x1, y1, x2, y2 + +real a, b + +begin + + a = x1 - x2 + b = y1 - y2 + return( sqrt( ( a * a ) + ( b * b ) ) ) + +end +#--------------------------------------------------------------------------- +# End of sp_distancer +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/spmapt.x b/pkg/utilities/nttools/stxtools/sp_util/spmapt.x new file mode 100644 index 00000000..cef87fed --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spmapt.x @@ -0,0 +1,94 @@ +include <gset.h> + +# Default viewport edges. +define EDGE1 0.1 +define EDGE2 0.9 +define EDGE3 0.12 +define EDGE4 0.85 + +#--------------------------------------------------------------------------- +.help sp_map_viewport Sep92 source +.ih +NAME +sp_map_viewport -- set device viewport for contour plots. +.endhelp +#--------------------------------------------------------------------------- + +procedure sp_map_viewport (gp, ncols, nlines, ux1, ux2, uy1, uy2, pre, perim) + +pointer gp # I: pointer to graphics descriptor +real ncols, nlines # I: size of image area, after block reduction +real ux1, ux2, uy1, uy2 # I: NDC coordinates of requested viewort +bool pre # I: Preserve aspect ratio. +bool perim # I: draw perimeter + +real xcen, ycen, x, y +real aspect_ratio +real x1, x2, y1, y2, ext, xdis, ydis +data ext /0.0625/ +real ggetr() + +begin + # Determine the standard window sizes. + if (!pre && !perim) { + x1 = 0.0; x2 = 1.0 + y1 = 0.0; y2 = 1.0 + } else { + x1 = EDGE1; x2 = EDGE2 + y1 = EDGE3; y2 = EDGE4 + + } + + # If any values were specified, then replace them here. + if( !IS_INDEFR( ux1 ) ) + x1 = ux1 + if( !IS_INDEFR( ux2 ) ) + x2 = ux2 + if( !IS_INDEFR( uy1 ) ) + y1 = uy1 + if( !IS_INDEFR( uy2 ) ) + y2 = uy2 + + xdis = x2 - x1 + ydis = y2 - y1 + xcen = ( x2 + x1 ) / 2. + ycen = ( y2 + y1 ) / 2. + + # So far, the viewport has been calculated so that equal numbers of + # image pixels map to equal distances in NDC space, regardless of + # the aspect ratio of the device. If preserving aspect ratio, + # modify viewport to correctly display the contour aspect. + if (pre) { + aspect_ratio = ggetr (gp, "ar") + if (aspect_ratio == 0.0) { + x = ggetr (gp, "xr") + y = ggetr (gp, "yr") + if ( x != 0.0 && y != 0.0) + aspect_ratio = y / x + else + aspect_ratio = 1.0 + } + aspect_ratio = nlines / ncols / aspect_ratio + x = ydis / aspect_ratio + y = ydis + if ( x > xdis) { + y = aspect_ratio * xdis + x = xdis + } + xdis = x + ydis = y + } + + # All set. + ux1 = xcen - (xdis / 2.0) + ux2 = xcen + (xdis / 2.0) + uy1 = ycen - (ydis / 2.0) + uy2 = ycen + (ydis / 2.0) + + call gsview (gp, ux1, ux2, uy1, uy2) + call gswind (gp, 1.0, ncols, 1.0, nlines) + +end +#--------------------------------------------------------------------------- +# End of sp_map_viewport +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/sprote.x b/pkg/utilities/nttools/stxtools/sp_util/sprote.x new file mode 100644 index 00000000..c9baeb65 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/sprote.x @@ -0,0 +1,49 @@ +include <math.h> + +# The dimensionality. +define N_DIM 2 + +# Define some memory management. +define ONER Memr[$1+$2-1] + +# sp_rotate - Rotate a vector. +# +# History +# 8Mar91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_rotate( x, y, npts, angle, nx, ny ) + +real x[npts], y[npts] # I: The vectors to rotate. +int npts # I: The number of points in the vectors. +real angle # I: The angle to rotate (radians). +real nx[npts], ny[npts] # O: The translated vectors. + +# Declarations +pointer center # To specify the center. +pointer mw # MWCS structure. +pointer sp # Stack pointer. + +# Function prototypes. +pointer mw_open(), mw_sctran() + +begin + + # Suck some memory. + call smark( sp ) + call salloc( center, N_DIM, TY_REAL ) + + mw = mw_open( NULL, N_DIM ) + ONER(center,1) = 0. + ONER(center,2) = 0. + call mw_rotate( mw, -DEGTORAD( angle ), ONER(center,1), 3b ) + call mw_v2tranr( mw_sctran( mw, "physical", "logical", 3b ), + x, y, nx, ny, npts ) + + call mw_close( mw ) + call sfree( sp ) + +end +#--------------------------------------------------------------------------- +# End of sp_rotate +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/spstry.x b/pkg/utilities/nttools/stxtools/sp_util/spstry.x new file mode 100644 index 00000000..545b0b06 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spstry.x @@ -0,0 +1,24 @@ +# sp_strncpy - Counted character copy. +# +# History +# 1Apr91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_strncpy( input, n_chars, output ) + +char input[ARB] # I: The input string to copy to the output. +int n_chars # I: The number of characters to copy. +char output[ARB] # O: The output string. + +# Declarations. +int i # Index. + +begin + + for( i = 1; i <= n_chars; i = i + 1 ) + output[i] = input[i] + +end +#--------------------------------------------------------------------------- +# End of sp_strncpy. +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/sptras.x b/pkg/utilities/nttools/stxtools/sp_util/sptras.x new file mode 100644 index 00000000..f62e9ceb --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/sptras.x @@ -0,0 +1,35 @@ +# Set the dimensionality +define N_DIM 2 + +# sp_trans - Translate the origin to a new center. +# +# History +# 11Mar91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_trans( x, y, npts, center, nx, ny ) + +real x[npts], y[npts] # I: The x, y vectors to translate. +int npts # I: The number of points in the vectors. +real center[N_DIM] # I: The new coordinate center. +real nx[npts], ny[npts] # O: The translated vectors. + +# Declarations +pointer mw # MWCS structure. + +# Function prototypes. +pointer mw_open(), mw_sctran() + +begin + + mw = mw_open( NULL, N_DIM ) + call mw_shift( mw, center, 3b ) + call mw_v2tranr( mw_sctran( mw, "physical", "logical", 3b ), + x, y, nx, ny, npts ) + + call mw_close( mw ) + +end +#--------------------------------------------------------------------------- +# End of sp_trans +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/spw2ld.x b/pkg/utilities/nttools/stxtools/sp_util/spw2ld.x new file mode 100644 index 00000000..a31ce22d --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spw2ld.x @@ -0,0 +1,50 @@ +# sp_w2ld - Transform world coordinates to logical coordinates (double). +# +# History +# 24Jun91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_w2ld( wlct, flip, wx, wy, lx, ly, npts ) + +pointer wlct # I: The MWCS coordinate trans. descriptor. +bool flip # I: True if the axes are transposed. +double wx[npts], wy[npts] # I: The world coordinates. +double lx[npts], ly[npts] # O: The logical coordinates. +int npts # I: The number of points to translate. + +begin + + if( flip ) + call mw_v2trand( wlct, wx, wy, ly, lx, npts ) + else + call mw_v2trand( wlct, wx, wy, lx, ly, npts ) + +end +#--------------------------------------------------------------------------- +# End of sp_w2ld +#--------------------------------------------------------------------------- +# sp_l2wd - Transform logical coordinates to world coordinates (double). +# +# History +# 24Jun91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_l2wd( lwct, flip, lx, ly, wx, wy, npts ) + +pointer lwct # I: The MWCS coordinate trans. descriptor. +bool flip # I: True if the axes are transposed. +double lx[npts], ly[npts] # I: The logical coordinates. +double wx[npts], wy[npts] # O: The world coordinates. +int npts # I: The number of points to translate. + +begin + + if( flip ) + call mw_v2trand( lwct, ly, lx, wx, wy, npts ) + else + call mw_v2trand( lwct, lx, ly, wx, wy, npts ) + +end +#--------------------------------------------------------------------------- +# End of sp_l2wd +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/spwcss.x b/pkg/utilities/nttools/stxtools/sp_util/spwcss.x new file mode 100644 index 00000000..bb2feb49 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spwcss.x @@ -0,0 +1,90 @@ +include <ctype.h> +include <imhdr.h> + +#--------------------------------------------------------------------------- +.help sp_wcsparams 3Aug95 source +.ih +NAME +sp_wcsparams -- Read the WCS descriptor from the parameters. +.ih +DESCRIPTION +This procedure returns the WCS descriptor created from task parameters +and the logical space that will be graphed. +.ih +BUGS +This only deals with two axes. +.endhelp +#--------------------------------------------------------------------------- +procedure sp_wcsparams( mw, log_x1, log_x2, log_y1, log_y2 ) + +pointer mw # O: The MWCS descriptor. +real log_x1, log_x2, + log_y1, log_y2 # O: The extent of the logical space to graph. + +# Declarations. +pointer b # Buffer pointer. +double clgetd() # Get double-valued parameter. +real clgetr() # Get real-valued parameter. +pointer im # Temporary image descriptor. +pointer immap() # Open an image. +pointer impl2s() # Put line in 2d image. +pointer imw # Temporary MWCS descriptor. +pointer mw_newcopy() # Copy MWCS descriptor. +pointer mw_openim() # Get MWCS descriptor from image. +char s[SZ_LINE] # Generic string. + +string tmpimage ".SPWCSS" + +begin + # Since no one knows how mwcs really works, we cheat. + # Create an image and set the header keywords to what + # the parameters are. Then use the image load to get the + # mwcs instead of trying to create it from scratch. + + # Create an image. + iferr (call imdelete (tmpimage)) + ; + im = immap (tmpimage, NEW_IMAGE, 20000) + IM_NDIM(im) = 2 + IM_LEN(im,1) = 1 + IM_LEN(im,2) = 1 + IM_PIXTYPE(im) = TY_SHORT + + # Now populate the WCS-relevant keywords. + call clgstr ("ctype1", s, SZ_LINE) + call imastr (im, "ctype1", s) + call clgstr ("ctype2", s, SZ_LINE) + call imastr (im, "ctype2", s) + call imaddd (im, "crpix1", clgetd ("crpix1")) + call imaddd (im, "crpix2", clgetd ("crpix2")) + call imaddd (im, "crval1", clgetd ("crval1")) + call imaddd (im, "crval2", clgetd ("crval2")) + call imaddd (im, "cd1_1", clgetd ("cd1_1")) + call imaddd (im, "cd1_2", clgetd ("cd1_2")) + call imaddd (im, "cd2_1", clgetd ("cd2_1")) + call imaddd (im, "cd2_2", clgetd ("cd2_2")) + + # Write a pixel, close and reopen the image. + b = impl2s (im, 1) + call imunmap (im) + im = immap (tmpimage, READ_ONLY, 0) + + # Retrieve the MWCS descriptor. Make a copy so we can close the + # temporary image. + imw = mw_openim (im) + mw = mw_newcopy (imw) + + # Get the logical workspace. + log_x1 = clgetr ("log_x1") + log_x2 = clgetr ("log_x2") + log_y1 = clgetr ("log_y1") + log_y2 = clgetr ("log_y2") + + # That's all folks. + call mw_close (imw) + call imunmap (im) + call imdelete (tmpimage) +end +#--------------------------------------------------------------------------- +# End of sp_wcsparams +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/strjust.x b/pkg/utilities/nttools/stxtools/strjust.x new file mode 100644 index 00000000..5f50f080 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/strjust.x @@ -0,0 +1,31 @@ +include <ctype.h> + +# STRJUST -- Remove whitspace from a string and convert to lower case +# +# B.Simon 30-Jan-95 copied from synphot$strfix + +procedure strjust (str) + +char str[ARB] # u: string to convert +#-- +int ic, jc + +begin + jc = 1 + for (ic = 1; str[ic] != EOS; ic = ic + 1) { + if (IS_WHITE(str[ic])) + next + + if (IS_UPPER(str[ic])) { + str[jc] = TO_LOWER(str[ic]) + + } else if (jc < ic) { + str[jc] = str[ic] + } + + jc = jc + 1 + } + + str[jc] = EOS +end + diff --git a/pkg/utilities/nttools/stxtools/stxgetcoord.x b/pkg/utilities/nttools/stxtools/stxgetcoord.x new file mode 100644 index 00000000..0fc9842c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/stxgetcoord.x @@ -0,0 +1,182 @@ +include <imhdr.h> +include <mwset.h> +include <math.h> + +define SZ_PNAME 8 + +# stx_getcoord -- get coordinate parameters +# This procedure gets the coordinate parameters from an image. +# The parameter values are gotten via mwcs, and the lterm is factored +# into the wterm so that the parameters are relative to the actual image +# section that was opened rather than to the "original" image. +# +# Phil Hodge, 5-Jan-1993 Copied from fourier$lib/loadct.x. +# Phil Hodge, 2-Feb-1994 Errchk mwcs routines. + +procedure stx_getcoord (im, crpix, crval, cd, maxdim, ctype, maxch) + +pointer im # i: pointer to imhdr struct for input image +double crpix[ARB] # o: reference pixel +double crval[ARB] # o: coordinates at reference pixel +double cd[maxdim,maxdim] # o: derivatives of l & m with respect to x & y +int maxdim # i: dimension of arrays (e.g. IM_MAXDIM) +char ctype[maxch,maxdim] # o: coord. type of each axis (e.g. "RA---TAN") +int maxch # i: size of ctype string (e.g. SZ_CTYPE) +#-- +pointer mw + +double o_crval[IM_MAXDIM] # world coordinates at reference pixel +double o_crpix[IM_MAXDIM] # not corrected for image section +double o_cd[IM_MAXDIM,IM_MAXDIM] # wterm only (not corr. for section) + +double n_crpix[IM_MAXDIM] # corrected for image section +double n_cd[IM_MAXDIM,IM_MAXDIM] # CD matrix corrected for section + +double ltm[IM_MAXDIM,IM_MAXDIM] # lterm matrix +double i_ltm[IM_MAXDIM,IM_MAXDIM] # inverse of ltm +double ltv[IM_MAXDIM] # lterm vector + +int ndim # dimension of image +int wcsdim # dimension of mwcs coordinates +pointer mw_openim() +int mw_stati() +errchk mw_openim, mw_stati, mw_gwtermd, mw_gltermd, mw_invertd, mw_close, + stx_extract + +begin + ndim = IM_NDIM(im) + if (ndim > maxdim) + call error (1, + "stx_getcoord: dimension of image is larger than array size") + + mw = mw_openim (im) + wcsdim = mw_stati (mw, MW_NPHYSDIM) # get mwcs dimension + + # Get the wterm and the lterm. + call mw_gwtermd (mw, o_crpix, o_crval, o_cd, wcsdim) + call mw_gltermd (mw, ltm, ltv, wcsdim) + + # Convert the wterm to be the values relative to the current + # image section. (Comments & code copied from mwcs.) + + # Output CRPIX = R' = (LTM * R + LTV). + call mw_vmuld (ltm, o_crpix, n_crpix, wcsdim) + call aaddd (ltv, n_crpix, n_crpix, wcsdim) + + # Output CD matrix = CD' = (CD * inv(LTM)). + call mw_invertd (ltm, i_ltm, wcsdim) + call mw_mmuld (o_cd, i_ltm, n_cd, wcsdim) + + # Extract the coordinate parameters, and get ctype. + call stx_extract (im, mw, n_crpix, o_crval, n_cd, wcsdim, + crpix, crval, cd, maxdim, ctype, maxch) + + call mw_close (mw) + + # Check for invalid CD matrix. + if (ndim == 1) { + if (cd[1,1] == 0.d0) { + call eprintf ("warning: pixel spacing = 0; reset to 1\n") + cd[1,1] = 1.d0 + } + } else if (ndim == 2) { + if (cd[1,1] * cd[2,2] - cd[1,2] * cd[2,1] == 0.d0) { + call eprintf ( + "warning: CD matrix is singular; reset to identity matrix\n") + cd[1,1] = 1.d0 + cd[2,1] = 0.d0 + cd[1,2] = 0.d0 + cd[2,2] = 1.d0 + } + } +end + +# stx_extract -- extract coordinate parameters +# This routine is needed to take care of the situation where the dimension +# of the input image was reduced by taking an image section. In that case, +# the coordinate information gotten using mwcs has the dimension of the +# original image, which results in two problems. (1) We need to know which +# axis of the original image maps to which axis of the image that we've +# got. (2) We have to dimension the CD matrix differently. When MWCS +# puts values into a 2-D array it is dimensioned wcsdim X wcsdim, but we +# declared it maxdim X maxdim in the calling routine. In this routine +# we declare the input CD matrix to be wcsdim X wcsdim, while the output +# CD matrix is maxdim X maxdim. + +procedure stx_extract (im, mw, n_crpix, n_crval, n_cd, wcsdim, + crpix, crval, cd, maxdim, ctype, maxch) + +pointer im # i: pointer to imhdr struct for input image +pointer mw # i: mwcs pointer +double n_crpix[wcsdim] # i: crpix +double n_crval[wcsdim] # i: crval +double n_cd[wcsdim,wcsdim] # i: CD matrix +int wcsdim # i: dimension of wcs +double crpix[maxdim] # o: crpix extracted from n_crpix +double crval[maxdim] # o: crval extracted from n_crval +double cd[maxdim,maxdim] # o: CD matrix extracted from n_cd +int maxdim # i: dimension of arrays (e.g. IM_MAXDIM) +char ctype[maxch,maxdim] # o: coord. type of each axis (e.g. "RA---TAN") +int maxch # i: size of ctype string (e.g. SZ_CTYPE) +#-- +char keyword[SZ_PNAME] # keyword for getting ctype +int ndim # actual dimension of image +int axno[IM_MAXDIM] # axis numbers +int axval[IM_MAXDIM] # ignored +int ax[IM_MAXDIM] # physical axis number for each logical axis +int i, j +bool ax_ok # for checking that axis numbers were found +int imaccf() +errchk mw_gaxmap + +begin + ndim = IM_NDIM(im) + + # Get the axis mapping. + call mw_gaxmap (mw, axno, axval, wcsdim) + + # Find the image axis numbers corresponding to the mwcs numbers. + do i = 1, ndim # initialize + ax[i] = 0 + do j = 1, wcsdim { + do i = 1, ndim { + if (axno[j] == i) { + ax[i] = j + break + } + } + } + + # It's an error if any axis number was not found. + ax_ok = true # initial value + do i = 1, ndim { + if (ax[i] < 1) + ax_ok = false + } + if (!ax_ok) { +# call error (1, "stx_extract: mwcs axis mapping is messed up") +# This is a temporary fix to prevent crashing on a vax. + do i = 1, ndim + ax[i] = i + } + + # Extract crpix, crval and the CD matrix. + # Note that we transpose the CD matrix because of different + # conventions regarding how a matrix is stored. + do i = 1, ndim { + crpix[i] = n_crpix[ax[i]] + crval[i] = n_crval[ax[i]] + do j = 1, ndim + cd[i,j] = n_cd[ax[j],ax[i]] # transpose + } + + # Get ctype. + do i = 1, ndim { + call sprintf (keyword, SZ_PNAME, "ctype%d") + call pargi (ax[i]) # physical axis number + if (imaccf (im, keyword) == YES) + call imgstr (im, keyword, ctype[1,i], maxch) + else + call strcpy ("PIXEL", ctype[1,i], maxch) + } +end diff --git a/pkg/utilities/nttools/stxtools/template.h b/pkg/utilities/nttools/stxtools/template.h new file mode 100644 index 00000000..9df66f37 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/template.h @@ -0,0 +1,21 @@ +# TEMPLATE.H -- Structure used to expand image names over groups + +define LEN_TPSTRUCT 5 + +define TP_ROOTPTR Memi[$1] # Pointer to image root name +define TP_SECTPTR Memi[$1+1] # Pointer to image section +define TP_START Memi[$1+2] # First group +define TP_COUNT Memi[$1+3] # Total number of groups +define TP_INDEX Memi[$1+4] # Current group + +define TP_ROOT Memc[TP_ROOTPTR($1)] +define TP_SECT Memc[TP_SECTPTR($1)] + +define TP_EXT_LIST "|stf|fxf|oif|plf|qpf|" + +define TP_UNKNOWN 0 +define TP_GEIS 1 +define TP_FITS 2 +define TP_IRAF 3 +define TP_PIXLIST 4 +define TP_QPOE 5 diff --git a/pkg/utilities/nttools/stxtools/tpbreak.x b/pkg/utilities/nttools/stxtools/tpbreak.x new file mode 100644 index 00000000..be5aed1d --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpbreak.x @@ -0,0 +1,80 @@ +# TP_BREAK -- Break an image name into bracket delimeted substrings +# +# B.Simon 02-Jun-89 Original + +procedure tp_break (imname, part, npart, maxch) + +char imname[ARB] # i: Image name +char part[maxch,ARB] # o: Array of image name parts +int npart # i: Maximum number of parts +int maxch # i: Maximum length of part +#-- +bool inside +char ch +int ic, jc, ipart +pointer sp, errmsg + +string syntax "Syntax error in image name (%s)" + +begin + # Allocate memory for error message + + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Initialize output to null string + + do ipart = 1, npart + part[1,ipart] = EOS + + # Break image name into bracket delimeted components + # The variable inside is used as a check that brackets are paired + + jc = 1 + ipart = 1 + inside = false + + for (ic = 1; ipart <= npart && imname[ic] != EOS; ic = ic + 1) { + + ch = imname[ic] + if (ch == '\\') { + ic = ic + 1 + + } else if (ch == '[') { + if (inside) { + call sprintf (Memc[errmsg], SZ_LINE, syntax) + call pargstr (imname) + call error (1, Memc[errmsg]) + } + part[jc,ipart] = EOS + ipart = ipart + 1 + inside = true + jc = 1 + + } else if (ch == ']') { + if (! inside) { + call sprintf (Memc[errmsg], SZ_LINE, syntax) + call pargstr (imname) + call error (1, Memc[errmsg]) + } + inside = false + + } else if (ipart > 1 && ! inside) { + call sprintf (Memc[errmsg], SZ_LINE, syntax) + call pargstr (imname) + call error (1, Memc[errmsg]) + } + + part[jc,ipart] = imname[ic] + jc = jc + 1 + + if (jc > maxch) { + call sprintf (Memc[errmsg], SZ_LINE, syntax) + call pargstr (imname) + call error (1, Memc[errmsg]) + } + } + + part[jc,ipart] = EOS + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/tpclose.x b/pkg/utilities/nttools/stxtools/tpclose.x new file mode 100644 index 00000000..8afac19c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpclose.x @@ -0,0 +1,21 @@ +include "template.h" + +# TP_CLOSE -- Close the group template expansion routines + +# Free the dynamic memory used to store the group template structure +# +# B.Simon 28-Feb-89 Original +# B.Simon 21-Aug-91 Changed template structure + +procedure tp_close (ptr) + +pointer ptr # u: Pointer to list of file names +#-- +errchk mfree + +begin + call mfree (TP_ROOTPTR(ptr), TY_CHAR) + call mfree (TP_SECTPTR(ptr), TY_CHAR) + call mfree (ptr, TY_STRUCT) + ptr = NULL +end diff --git a/pkg/utilities/nttools/stxtools/tpcount.x b/pkg/utilities/nttools/stxtools/tpcount.x new file mode 100644 index 00000000..f233aa26 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpcount.x @@ -0,0 +1,134 @@ +include "template.h" + +# TP_COUNT -- Count the number of groups in an image +# +# B.Simon 02-Oct-98 Original +# B.Simon 26-Apr-99 Check value of NEXTEND before using + +int procedure tp_count (root) + +char root[ARB] # i: image name minus any sections +#-- +int imtype, count, lo, hi, mid +pointer sp, image, im + +int imgeti(), imaccf(), tp_imtype(), tp_hasgroup() +pointer immap() + +begin + # If the image is not a geis or fits file it can only have one group + + imtype = tp_imtype (root) + if (imtype != TP_GEIS && imtype != TP_FITS) + return (1) + + # Open the image to read the number of groups or extensions + # as recorded in the appropriate header keyword + + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + + call strcpy (root, Memc[image], SZ_FNAME) + call strcat ("[0]", Memc[image], SZ_FNAME) + + iferr (im = immap (Memc[image], READ_ONLY, NULL)) { + # If image can't be opened, report an error condition + + count = ERR + + } else if (imtype == TP_GEIS) { + # Number of groups is trustworthy, report it to user + + count = imgeti (im, "GCOUNT") + call imunmap (im) + + } else { + # Number of extensions is not, it must be checked + + lo = 1 + hi = 0 + + # Check number of extensions + + if (imaccf (im, "NEXTEND") == YES) { + mid = imgeti (im, "NEXTEND") + + if (mid > 0) { + if (tp_hasgroup (root, mid) == NO) { + hi = mid + + } else { + lo = mid + mid = mid + 1 + + if (tp_hasgroup (root, mid) == NO) { + hi = mid + } else { + lo = mid + } + } + } + } + + # Find bracket for number of extensions + + while (hi < lo) { + mid = 2 * lo + + if (tp_hasgroup (root, mid) == NO) { + hi = mid + } else { + lo = mid + } + } + + # Use binary search to find actual number of extensions + + while (hi - lo > 1) { + mid = (hi + lo) / 2 + + if (tp_hasgroup (root, mid) == NO) { + hi = mid + } else { + lo = mid + } + } + + count = lo + call imunmap (im) + } + + call sfree (sp) + return (count) +end + +# TP_HASGROUP -- Determine if group is preent in image + +int procedure tp_hasgroup (root, index) + +char root[ARB] # i: image name +int index # i: index of group to check +#-- +int has +pointer sp, image, im + +pointer immap() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[image], SZ_FNAME, "%s[%d]") + call pargstr (root) + call pargi (index) + + iferr (im = immap (Memc[image], READ_ONLY, NULL)) { + has = NO + } else { + call imunmap (im) + has = YES + } + + call sfree (sp) + return (has) +end diff --git a/pkg/utilities/nttools/stxtools/tpfetch.x b/pkg/utilities/nttools/stxtools/tpfetch.x new file mode 100644 index 00000000..885fd847 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpfetch.x @@ -0,0 +1,43 @@ +include "template.h" + +# TP_FETCH -- Fetch the next image name from the group image template +# +# Create the next file name from the structure created by tp_open. +# Return true if another group exists, false otherwise. +# +# B.Simon 28-Feb-89 Original +# B.Simon 21-Aug-91 Changed template structure +# B.Simon 24-Jul-98 Revised to handle unparsable sections + +bool procedure tp_fetch (ptr, file_name) + +pointer ptr # i: A pointer to a list of file names +char file_name[SZ_FNAME] # o: The next file name in the list +#-- + +begin + if ((TP_INDEX(ptr) - TP_START(ptr)) + 1 > TP_COUNT(ptr)) + return (false) + + if (TP_START(ptr) == ERR) { + call sprintf (file_name, SZ_FNAME, "%s%s") + call pargstr (TP_ROOT(ptr)) + call pargstr (TP_SECT(ptr)) + + } else if (TP_COUNT(ptr) > 1 && TP_INDEX(ptr) == TP_START(ptr)) { + call sprintf (file_name, SZ_FNAME, "%s[%d/%d]%s") + call pargstr (TP_ROOT(ptr)) + call pargi (TP_INDEX(ptr)) + call pargi (TP_COUNT(ptr)) + call pargstr (TP_SECT(ptr)) + + } else { + call sprintf (file_name, SZ_FNAME, "%s[%d]%s") + call pargstr (TP_ROOT(ptr)) + call pargi (TP_INDEX(ptr)) + call pargstr (TP_SECT(ptr)) + } + + TP_INDEX(ptr) = TP_INDEX(ptr) + 1 + return (true) +end diff --git a/pkg/utilities/nttools/stxtools/tpgroup.x b/pkg/utilities/nttools/stxtools/tpgroup.x new file mode 100644 index 00000000..1dac1895 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpgroup.x @@ -0,0 +1,87 @@ +include <ctype.h> +include <imio.h> + +# TP_GROUP -- Extract the group index and count from an image name +# +# B.Simon 02-Jun-89 Original +# B.Simon 10-Jul-98 Revised to ignore what it can't parse +# B.Simon 02-Oct-98 added call to tp_count +# B.Simon 26-Apr-99 set index to ERR if undefined + +procedure tp_group (root, gsect, def_count, index, count) + +char root[ARB] # i: Root section of image name +char gsect[ARB] # i: Group section of image name +int def_count # i: Default count if not specified +int index # o: Starting group index +int count # o: Group count +#-- +bool star +int ic, inum, num[2] + +int tp_count() + +begin + inum = 0 + num[1] = 0 + num[2] = 0 + star = false + + # Extract the numeric fields from the group section + # Set a flag if a star was found + + for (ic = 1; gsect[ic] != EOS; ic = ic + 1) { + switch (gsect[ic]) { + case ' ': + ; + case '[': + inum = 1 + case ']': + break + case '*': + star = true + inum = inum - 1 + case '/': + inum = inum + 1 + default: + if (! star && IS_DIGIT(gsect[ic])) { + if (inum > 2) { + inum = 2 + break + } + num[inum] = 10 * num[inum] + TO_INTEG(gsect[ic]) + + } else { + inum = 0 + star = false + break + } + } + } + + # Set the output variables according to the number of fields found + + switch (inum) { + case 0: + index = ERR + count = ERR + case 1: + index = num[1] + count = 1 + case 2: + index = num[1] + count = max (1, num[2]) + } + + # Either use the default count or if the default is zero, + # Open the image and read the count from it + + if (star) { + if (def_count > 0) { + count = def_count + + } else { + count = tp_count (root) + } + } +end diff --git a/pkg/utilities/nttools/stxtools/tpimtype.x b/pkg/utilities/nttools/stxtools/tpimtype.x new file mode 100644 index 00000000..3ed7580f --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpimtype.x @@ -0,0 +1,116 @@ +include <ctype.h> +include "template.h" + +define MAXEXT 25 + +# TP_IMTYPE -- Determine image type from image extension +# +# B.Simon 02-Oct-98 Original + +int procedure tp_imtype (root) + +int root[ARB] # i: image extension +#-- +int loadext +pointer extlist[MAXEXT] +pointer extbuf + +data loadext / NO / + +int nc, iext, imtype +pointer sp, ext + +int fnextn(), strdic(), iki_validextn() + +begin + call smark (sp) + call salloc (ext, SZ_FNAME, TY_CHAR) + + if (loadext == NO) { + call tp_loadext (extlist, extbuf) + loadext = YES + } + + nc = fnextn (root, Memc[ext], SZ_FNAME) + iext = iki_validextn (0, Memc[ext]) + + if (iext == 0) { + imtype = TP_UNKNOWN + + } else { + call strcpy (Memc[extlist[iext]], Memc[ext], SZ_FNAME) + imtype = strdic (Memc[ext], Memc[ext], SZ_FNAME, TP_EXT_LIST) + } + + call sfree (sp) + return (imtype) +end + +# TP_LOADEXT -- Load list of image kernel names indexed by extension + +procedure tp_loadext (extlist, extbuf) + +pointer extlist[MAXEXT] # o: pointers to kernel names +int extbuf # o: string buffer containing names +#-- +int fd, flags, taglen, iext, ic, jc, nc +pointer sp, line, jstr, kstr + +string kernel_tag "installed kernels " + +int open(), strlen(), getline(), strncmp(), ctoi() + +begin + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Initialize the image kernel tables + + call iki_init () + + # Call the kernel debug routine to dump the information + # about which kernels are associated with which indices + + fd = open ("tp_spool", READ_WRITE, SPOOL_FILE) + call iki_debug ("Kernel Names", fd, flags) + + # Search the file for the line containing the image kernel info + + call seek (fd, BOF) + taglen = strlen (kernel_tag) + + while (getline (fd, Memc[line]) != EOF) { + if (strncmp (Memc[line], kernel_tag, taglen) != 0) + next + + # Parse the line to extract the info + + call malloc (extbuf, strlen (Memc[line+taglen]), TY_CHAR) + jstr = extbuf + kstr = extbuf + + for (ic = taglen; Memc[line+ic] != EOS; ic = ic + 1) { + if (Memc[line+ic] == '=') { + Memc[jstr] = EOS + jstr = jstr + 1 + + jc = 1 + nc = ctoi (Memc[line+ic+1], jc, iext) + ic = ic + 1 + + extlist[iext] = kstr + kstr = jstr + + } else if (! IS_WHITE (Memc[line+ic])) { + Memc[jstr] = Memc[line+ic] + jstr = jstr + 1 + } + } + + break + } + + call close (fd) + call sfree (sp) +end + diff --git a/pkg/utilities/nttools/stxtools/tpopen.x b/pkg/utilities/nttools/stxtools/tpopen.x new file mode 100644 index 00000000..d9b7a2af --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpopen.x @@ -0,0 +1,38 @@ +include "template.h" + +# TP_OPEN -- Expand a group image template into a list of image names. + +# Create an array of image names that contain the group specification. +# Return a pointer to the list of names and the total number of names. +# +# B.Simon 28-Feb-89 Original +# B.Simon 23-Jun-89 Hint character added +# B.Simon 21-Aug-91 Changed template structure + +pointer procedure tp_open (imname, def_count, count) + +char imname[ARB] # i: image template +int def_count # i: default image name count +int count # o: number of image names +#-- +pointer ptr + +errchk tp_parse, malloc + +begin + # Allocate data structure + + call malloc (ptr, LEN_TPSTRUCT, TY_STRUCT) + call malloc (TP_ROOTPTR(ptr), SZ_FNAME, TY_CHAR) + call malloc (TP_SECTPTR(ptr), SZ_FNAME, TY_CHAR) + + # Parse the template into a root name, starting group number, + # and group count + + call tp_parse (imname, def_count, TP_ROOT(ptr), TP_SECT(ptr), + TP_START(ptr), TP_COUNT(ptr)) + + TP_INDEX(ptr) = TP_START(ptr) + count = TP_COUNT(ptr) + return(ptr) +end diff --git a/pkg/utilities/nttools/stxtools/tpparse.x b/pkg/utilities/nttools/stxtools/tpparse.x new file mode 100644 index 00000000..f261a763 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpparse.x @@ -0,0 +1,108 @@ +include <imio.h> + +define NFIELD 4 +define FIELD Memc[($1)+($2-1)*(SZ_FNAME+1)] + +# TP_PARSE -- Parse an image name into its component parts +# +# Parse an image name to obtain the root name, the image section, the +# group index, and the group count. +# +# B.Simon 28-Feb-89 Original +# B.Simon 02-Jun-89 imparse replaced +# B.Simon 16-Jul-98 Revised to flag unparsable sections +# B.Simon 02-Oct-98 added call to tp_count +# B.Simon 26-Apr-99 check for data in extension zero +# B.Simon 06-May-99 set index to one for new files w/o sections +# B.Simon 14-Jun-99 set count to one if section could not be parsed +# B.Simon 20-Nov-00 get default extension with iki_access + +procedure tp_parse (imname, def_count, root, section, index, count) + +char imname[ARB] # i: image name +int def_count # i: default group count +char root[ARB] # o: root name +char section[ARB] # o: image section +int index # o: group index +int count # o: group count +#-- +int ifield, nc +pointer sp, image, root2, sect, ext + +int access(), strlen(), fnextn(), envgets(), iki_access() +int tp_count(), tp_hasgroup() + +string ambiguous " Ambiguous image name, extension required" + +errchk immap, imunmap + +begin + # Allocate dynamic memory for error string + + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (root2, SZ_FNAME, TY_CHAR) + call salloc (sect, (SZ_FNAME+1)*NFIELD, TY_CHAR) + call salloc (ext, SZ_FNAME, TY_CHAR) + + # Break the image name into its component parts and + # get the group index and count + + call tp_break (imname, Memc[sect], NFIELD, SZ_FNAME) + + call tp_group (FIELD(sect,1), FIELD(sect,2), def_count, index, count) + + call strcpy (FIELD(sect,1), root, SZ_FNAME) + call strcpy (FIELD(sect,2), section, SZ_FNAME) + + # Copy the remaining fields into the section + + do ifield = 3, NFIELD + call strcat (FIELD(sect,ifield), section, SZ_FNAME) + + # Add default extension onto image if no extension given + + nc = strlen (root) + if (root[nc] != '.' && fnextn (root, Memc[ext], SZ_FNAME) == 0) { + # Determine the access mode from the default grou[ count + + if (def_count > 0) { + nc = envgets ("imtype", Memc[ext], SZ_FNAME) + + } else { + if (iki_access (root, Memc[root2], + Memc[ext], READ_ONLY) == ERR) + call error (1, ambiguous) + } + + call strcat (".", root, SZ_FNAME) + call strcat (Memc[ext], root, SZ_FNAME) + } + + # Set index and count when the image does not contain a section + + if (section[1] == EOS) { + if (access (root, 0, 0) == NO) { + index = 1 + } else if (tp_hasgroup (root, 1) == YES) { + index = 1 + } else { + index = 0 + } + } + + if (count != ERR) { + count = max (count, 1) + + } else if (index == ERR) { + count = 1 + + } else if (def_count > 0) { + count = def_count + + } else { + count = tp_count (root) + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/vex.com b/pkg/utilities/nttools/stxtools/vex.com new file mode 100644 index 00000000..d89b8788 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vex.com @@ -0,0 +1,11 @@ +# VEX.COM -- Global variables used by vex parsing routine + +pointer line # Buffer containing next line in expression +pointer ch # Pointer to next character in expression +int ncode # Length of code array +int maxcode # Maximum length of code array +pointer code # Pointer to next available code +pointer stack # Pointer to stack structure + +common /vex/ line, ch, ncode, maxcode, code, stack + diff --git a/pkg/utilities/nttools/stxtools/vex.h b/pkg/utilities/nttools/stxtools/vex.h new file mode 100644 index 00000000..200d717c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vex.h @@ -0,0 +1,107 @@ +# VEX.H -- Structures and constants used by vex + +# Strings + +define FN1STR "abs acos asin atan cos cosh cube double exp int log log10 \ +nint real sin sinh sqr sqrt tan tanh" + +define FN2STR "atan2 dim max min mod sign" + +# Characters + +define BLANK ' ' +define CMTCHAR '#' +define DOLLAR '$' +define DOT '.' + +# Function codes + +define FN1_ABS 1 +define FN1_ACOS 2 +define FN1_ASIN 3 +define FN1_ATAN 4 +define FN1_COS 5 +define FN1_COSH 6 +define FN1_CUBE 7 +define FN1_DOUBLE 8 +define FN1_EXP 9 +define FN1_INT 10 +define FN1_LOG 11 +define FN1_LOG10 12 +define FN1_NINT 13 +define FN1_REAL 14 +define FN1_SIN 15 +define FN1_SINH 16 +define FN1_SQR 17 +define FN1_SQRT 18 +define FN1_TAN 19 +define FN1_TANH 20 + +define FN2_ATAN2 1 +define FN2_DIM 2 +define FN2_MAX 3 +define FN2_MIN 4 +define FN2_MOD 5 +define FN2_SIGN 6 + +# These constants are taken from the output of xyacc run on vexcompile.y + +define Y_WRONG 257 +define Y_LPAR 258 +define Y_RPAR 259 +define Y_COMMA 260 +define Y_VAR 261 +define Y_INT 262 +define Y_REAL 263 +define Y_DOUBLE 264 +define Y_FN1 265 +define Y_FN2 266 +define Y_IF 267 +define Y_THEN 268 +define Y_ELSE 269 +define Y_DONE 270 +define Y_OR 271 +define Y_AND 272 +define Y_NOT 273 +define Y_EQ 274 +define Y_NE 275 +define Y_LT 276 +define Y_GT 277 +define Y_LE 278 +define Y_GE 279 +define Y_ADD 280 +define Y_SUB 281 +define Y_MUL 282 +define Y_DIV 283 +define Y_NEG 284 +define Y_POW 285 + +# Array lengths + +define MAX_TOKEN 31 +define MAX_STACK 64 + +# Pseudocode structure + +define SZ_VEXSTRUCT 2 + +define VEX_CODE Memi[$1] # pointer to code array +define VEX_STACK Memi[$1+1] # pointer to stack structure + +# Stack structure + +define SZ_STKSTRUCT 6 + +define STK_TOP Memi[$1] # top of stack +define STK_HIGH Memi[$1+1] # high water mark in stack +define STK_LENVAL Memi[$1+2] # length of each value array +define STK_NULLARY Memi[$1+3] # pointer to array of null values +define STK_VALARY Memi[$1+4] # pointer to value stack +define STK_TYPARY Memi[$1+5] # pointer to type stack + +define STK_NULL Memb[STK_NULLARY($1)+$2] +define STK_VALUE Memi[STK_VALARY($1)+$2] +define STK_TYPE Memi[STK_TYPARY($1)+$2] + +define TOP -1 # Symbolic constant for top of stack + diff --git a/pkg/utilities/nttools/stxtools/vexcompile.x b/pkg/utilities/nttools/stxtools/vexcompile.x new file mode 100644 index 00000000..c7054b2d --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexcompile.x @@ -0,0 +1,973 @@ +include <lexnum.h> +include <ctype.h> +include <fset.h> +include "vex.h" + +#* HISTORY * +#* B.Simon ?? original +# Phil Hodge 12-Jul-2005 Add 'int vex_gettok()' and declare 'debug' +# to be bool rather than int, in vex_compile. + +define YYMAXDEPTH 64 +define YYOPLEN 1 +define yyparse vex_parse + +# Tokens generated by xyacc have been moved to vex.h + +define yyclearin yychar = -1 +define yyerrok yyerrflag = 0 +define YYMOVE call amovi (Memi[$1], Memi[$2], YYOPLEN) +define YYERRCODE 256 + +# line 148 "vexcompile.y" + + +# VEX_COMPILE -- Compile an expression, producing pseudocode +# +# This procedure takes a string containing a fortran expression and produces +# pseudocode that can be evaluated by vex_eval(). The pseudocode is stored in +# structure adressed by the pointer returned as the function value. This +# structure is freed by calling vex_free(). If the string begins with an @ +# symbol, the rest of the string is treated as a the name of a file which +# contains the expression. The expression can contain all the fortran +# operators, including logical and relational operators and supports all the +# fortran intrinsic functions which can take real arguments. It also supports +# conditional expressions of the form: if <expr> then <expr> else <expr> +# Variables must follow the fortran rules, and may be up to 31 characters long. +# All variables and constants are treated as real numbers. A variable may +# contain non-alphanumeric characters if it is preceded by a dollar sign, in +# which case all characters until the next blank are part of the variable name. +# +# B.Simon 21-May-90 Original +# B.Simon 19-Apr-91 Revised to handle multiple types +# B.Simon 31-Mar-94 Better syntax error message +# B.Simon 15-Oct-98 Embed strings in pseudocode + +pointer procedure vex_compile (expr) + +char expr[ARB] # i: Expression to be parsed +#-- +include "vex.com" + +int ic, fd, len +bool debug +pointer sp, pcode + +data debug / false / + +int open(), stropen(), strlen(), fstati(), yyparse() + +int vex_gettok() +extern vex_gettok + +begin + # Open the expression as a file + + for (ic = 1; IS_WHITE(expr[ic]); ic = ic + 1) + ; + + if (expr[ic] == '@') { + fd = open (expr[ic+1], READ_ONLY, TEXT_FILE) + len = fstati (fd, F_FILESIZE) + 1 + + } else { + len = strlen (expr[ic]) + 1 + fd = stropen (expr[ic], len, READ_ONLY) + } + + # Create pseudocode structure + + call malloc (pcode, SZ_VEXSTRUCT, TY_STRUCT) + + call malloc (VEX_CODE(pcode), 2 * len, TY_INT) + call stk_init (VEX_STACK(pcode)) + + # Initialize parsing common block + + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + ch = line + Memc[line] = EOS + + ncode = 0 + maxcode = 2 * len + code = VEX_CODE(pcode) + stack = VEX_STACK(pcode) + + # Parse expression to produce reverse polish code + + if (yyparse (fd, debug, vex_gettok) == ERR) { + call eprintf ("%s\n%*t^\n") + call pargstr (Memc[line]) + call pargi (ch-line) + + call error (1, "Syntax error in expression") + } + + # Clean up and return pseudocode structure + + call stk_clear (VEX_STACK(pcode)) + + call close (fd) + call sfree (sp) + return (pcode) +end + +# VEX_GETTOK -- Get the next token from the input + +int procedure vex_gettok (fd, value) + +int fd # i: File containing expression to be lexed +pointer value # o: Address on parse stack to store token +#-- +include "vex.com" + +double constant +int ic, jc, nc, type, index +int idftype[4], keytype[3], btype[9] +pointer sp, errmsg, token + +string fn1tok FN1STR +string fn2tok FN2STR + +string idftok "indefi indefr indefd indef" +data idftype / Y_INT, Y_REAL, Y_DOUBLE, Y_REAL / + +string keytok "if then else" +data keytype / Y_IF, Y_THEN, Y_ELSE / + +string btoken ".or. .and. .eq. .ne. .lt. .gt. .le. .ge. .not." +data btype / Y_OR, Y_AND, Y_EQ, Y_NE, Y_LT, Y_GT, Y_LE, Y_GE, Y_NOT / + +string badsymb "Operator not recognized (%s)" + +int getline(), lexnum(), ctod(), stridxs(), word_match() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call malloc (token, MAX_TOKEN, TY_CHAR) + + # Skip over leading white space and comments + + while (Memc[ch] <= BLANK || Memc[ch] == CMTCHAR) { + + # If all characters have been read from the current line + # or a comment character was found, get the next line + + if (Memc[ch] == EOS || Memc[ch] == CMTCHAR) { + ch = line + if (getline (fd, Memc[line]) == EOF) { + Memc[ch] = EOS + break + } + } else { + ch = ch + 1 + } + } + + # The token type is determined from the first character in the token + + Memc[token] = EOS + + # End of expression token + + if (Memc[ch] == EOS) { + type = Y_DONE + + # Numeric constant is too difficult to parse, + # Pass the job to lexnum and ctod + + } else if (IS_DIGIT(Memc[ch])) { + + ic = 1 + index = lexnum (Memc[ch], ic, nc) + if (index != LEX_REAL) { + type = Y_INT + } else if (nc > 8) { + type = Y_DOUBLE + } else { + jc = stridxs ("dD", Memc[ch]) + if (jc == 0 || jc > nc) { + type = Y_REAL + } else { + type = Y_DOUBLE + } + } + + ic = 1 + nc = ctod (Memc[ch], ic, constant) + nc = min (nc, MAX_TOKEN) + + call strcpy (Memc[ch], Memc[token], nc) + ch = ch + ic - 1 + + # Token is alphanumeric. Determine what type of token + + } else if (IS_ALPHA (Memc[ch])) { + + # Gather characters in token + + for (ic = 1; ic <= MAX_TOKEN; ic = ic + 1) { + if (Memc[ch] != '_' && ! IS_ALNUM(Memc[ch])) + break + + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + Memc[token+ic-1] = EOS + + # Check to see if token is string "INDEF" + + index = word_match (Memc[token], idftok) + + if (index > 0) { + type = idftype[index] + call strupr (Memc[token]) + + } else { + + # Check to see if token is function or keyword name + # If not, add it as a new variable + + index = word_match (Memc[token], fn1tok) + if (index > 0) { + type = Y_FN1 + + } else { + index = word_match (Memc[token], fn2tok) + if (index > 0) { + type = Y_FN2 + + } else { + index = word_match (Memc[token], keytok) + if (index > 0) { + type = keytype[index] + Memc[token] = EOS + } else { + type = Y_VAR + } + } + } + } + + # Tokens beginning with a dot are numbers or boolean operators + + } else if (Memc[ch] == DOT) { + + if (IS_DIGIT (Memc[ch+1])) { + ic = 1 + index = lexnum (Memc[ch], ic, nc) + + if (index != LEX_REAL) { + type = Y_INT + } else if (nc < 9) { + type = Y_REAL + } else { + type = Y_DOUBLE + } + + ic = 1 + nc = ctod (Memc[ch], ic, constant) + nc = min (nc, MAX_TOKEN) + + call strcpy (Memc[ch], Memc[token], nc) + ch = ch + ic - 1 + + } else { + + # Gather characters in token + + ch = ch + 1 + Memc[token] = DOT + for (ic = 2; ic < MAX_TOKEN && Memc[ch] != DOT; ic = ic + 1) { + if (Memc[ch] == EOS) + break + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + + Memc[token+ic-1] = Memc[ch] + Memc[token+ic] = EOS + ch = ch + 1 + + index = word_match (Memc[token], btoken) + if (type > 0) { + type = btype[index] + } else { + call sprintf (Memc[errmsg], SZ_LINE, badsymb) + call pargstr (Memc[token]) + call error (1, Memc[errmsg]) + } + } + + # Characters preceded by a dollar sign are identifiers + + } else if (Memc[ch] == DOLLAR) { + + ch = ch + 1 + for (ic = 1; ic <= MAX_TOKEN && Memc[ch] > BLANK; ic = ic + 1) { + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + Memc[token+ic-1] = EOS + + type = Y_VAR + + # Anything else is a symbol + + } else { + switch (Memc[ch]) { + case '*': + if (Memc[ch+1] != '*') { + type = Y_MUL + } else { + type = Y_POW + ch = ch + 1 + } + case '/': + type = Y_DIV + case '+': + type = Y_ADD + case '-': + type = Y_SUB + case '(': + type = Y_LPAR + case ')': + type = Y_RPAR + case ',': + type = Y_COMMA + case '<': + if (Memc[ch+1] != '=') { + type = Y_LT + } else { + type = Y_LE + ch = ch + 1 + } + case '>': + if (Memc[ch+1] != '=') { + type = Y_GT + } else { + type = Y_GE + ch = ch + 1 + } + case '|': + if (Memc[ch+1] != '|') { + type = Y_WRONG + } else { + type = Y_OR + ch = ch + 1 + } + case '&': + if (Memc[ch+1] != '&') { + type = Y_WRONG + } else { + type = Y_AND + ch = ch + 1 + } + case '=': + if (Memc[ch+1] != '=') { + type = Y_WRONG + } else { + type = Y_EQ + ch = ch + 1 + } + case '!': + if (Memc[ch+1] != '=') { + type = Y_NOT + } else { + type = Y_NE + ch = ch + 1 + } + default: + Memc[ch+1] = EOS + call sprintf (Memc[errmsg], SZ_LINE, badsymb) + call pargstr (Memc[ch]) + call error (1, Memc[errmsg]) + } + + ch = ch + 1 + } + + # + if (Memc[token] == EOS) { + call mfree (token, TY_CHAR) + token = NULL + } + + Memi[value] = token + return (type) +end + +# VEX_ADDCODE -- Add an instruction to the code array + +procedure vex_addcode (type) + +int type # i: Instruction type +#-- +include "vex.com" + +begin + + if (ncode == maxcode) + call error (1, "Expression too complex") + else { + Memi[code] = type + code = code + 1 + ncode = ncode + 1 + } + +end + +# VEX_ADDSTR -- Embed a string constant in the pseudo-code + +procedure vex_addstr (token) + +pointer token # u: Pointer to token string +#-- +include "vex.com" + +int ic + +begin + if (token == NULL) + call error (1, "Expression token missing") + + if (Memc[token] == EOS) + call error (1, "Expression token blank") + + ic = 0 + repeat { + ic = ic + 1 + + if (ncode == maxcode) + call error (1, "Expression too complex") + else { + Memi[code] = Memc[token+ic-1] + code = code + 1 + ncode = ncode + 1 + } + + } until (Memc[token+ic-1] == EOS) + + call mfree (token, TY_CHAR) +end + +# VEX_GETSTR -- Retrieve a token string from the pseudocode array + +procedure vex_getstr (op, token, maxch) + +pointer op # u: Location of token string in pseudocode +char token[ARB] # o: Token string +int maxch # i: Maximum length of token +#-- +int ic + +begin + # The token begins one position after op and is + # termminated by an EOS + + ic = 0 + repeat { + ic = ic + 1 + op = op + 1 + if (ic <= maxch) + token[ic] = Memi[op] + + } until (Memi[op] == EOS) + +end +define YYNPROD 27 +define YYLAST 264 +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Parser for yacc output, translated to the IRAF SPP language. The contents +# of this file form the bulk of the source of the parser produced by Yacc. +# Yacc recognizes several macros in the yaccpar input source and replaces +# them as follows: +# A user suppled "global" definitions and declarations +# B parser tables +# C user supplied actions (reductions) +# The remainder of the yaccpar code is not changed. + +define yystack_ 10 # statement labels for gotos +define yynewstate_ 20 +define yydefault_ 30 +define yyerrlab_ 40 +define yyabort_ 50 + +define YYFLAG (-1000) # defs used in user actions +define YYERROR goto yyerrlab_ +define YYACCEPT return (OK) +define YYABORT return (ERR) + + +# YYPARSE -- Parse the input stream, returning OK if the source is +# syntactically acceptable (i.e., if compilation is successful), +# otherwise ERR. The parameters YYMAXDEPTH and YYOPLEN must be +# supplied by the caller in the %{ ... %} section of the Yacc source. +# The token value stack is a dynamically allocated array of operand +# structures, with the length and makeup of the operand structure being +# application dependent. + +int procedure yyparse (fd, yydebug, yylex) + +int fd # stream to be parsed +bool yydebug # print debugging information? +int yylex() # user-supplied lexical input function +extern yylex() + +short yys[YYMAXDEPTH] # parser stack -- stacks tokens +pointer yyv # pointer to token value stack +pointer yyval # value returned by action +pointer yylval # value of token +int yyps # token stack pointer +pointer yypv # value stack pointer +int yychar # current input token number +int yyerrflag # error recovery flag +int yynerrs # number of errors + +short yyj, yym # internal variables +pointer yysp, yypvt +short yystate, yyn +int yyxi, i +errchk salloc, yylex + + + +short yyexca[70] +data (yyexca(i),i= 1, 8) / -1, 1, 0, -1, -2, 0, -1, 41/ +data (yyexca(i),i= 9, 16) / 276, 0, 277, 0, 278, 0, 279, 0/ +data (yyexca(i),i= 17, 24) / -2, 18, -1, 42, 276, 0, 277, 0/ +data (yyexca(i),i= 25, 32) / 278, 0, 279, 0, -2, 19, -1, 43/ +data (yyexca(i),i= 33, 40) / 276, 0, 277, 0, 278, 0, 279, 0/ +data (yyexca(i),i= 41, 48) / -2, 20, -1, 44, 276, 0, 277, 0/ +data (yyexca(i),i= 49, 56) / 278, 0, 279, 0, -2, 21, -1, 45/ +data (yyexca(i),i= 57, 64) / 274, 0, 275, 0, -2, 22, -1, 46/ +data (yyexca(i),i= 65, 70) / 274, 0, 275, 0, -2, 23/ +short yyact[264] +data (yyact(i),i= 1, 8) / 58, 22, 23, 24, 25, 20, 21, 18/ +data (yyact(i),i= 9, 16) / 19, 17, 17, 31, 29, 28, 15, 26/ +data (yyact(i),i= 17, 24) / 27, 22, 23, 24, 25, 20, 21, 18/ +data (yyact(i),i= 25, 32) / 19, 55, 17, 29, 28, 30, 26, 27/ +data (yyact(i),i= 33, 40) / 22, 23, 24, 25, 20, 21, 18, 19/ +data (yyact(i),i= 41, 48) / 54, 17, 20, 21, 18, 19, 1, 17/ +data (yyact(i),i= 49, 56) / 0, 0, 0, 29, 28, 0, 26, 27/ +data (yyact(i),i= 57, 64) / 22, 23, 24, 25, 20, 21, 18, 19/ +data (yyact(i),i= 65, 72) / 53, 17, 18, 19, 0, 17, 0, 0/ +data (yyact(i),i= 73, 80) / 0, 0, 2, 0, 29, 28, 0, 26/ +data (yyact(i),i= 81, 88) / 27, 22, 23, 24, 25, 20, 21, 18/ +data (yyact(i),i= 89, 96) / 19, 51, 17, 0, 0, 0, 0, 0/ +data (yyact(i),i= 97,104) / 0, 0, 0, 0, 0, 29, 28, 0/ +data (yyact(i),i=105,112) / 26, 27, 22, 23, 24, 25, 20, 21/ +data (yyact(i),i=113,120) / 18, 19, 35, 17, 0, 29, 28, 0/ +data (yyact(i),i=121,128) / 26, 27, 22, 23, 24, 25, 20, 21/ +data (yyact(i),i=129,136) / 18, 19, 57, 17, 29, 28, 0, 26/ +data (yyact(i),i=137,144) / 27, 22, 23, 24, 25, 20, 21, 18/ +data (yyact(i),i=145,152) / 19, 28, 17, 26, 27, 22, 23, 24/ +data (yyact(i),i=153,160) / 25, 20, 21, 18, 19, 0, 17, 26/ +data (yyact(i),i=161,168) / 27, 22, 23, 24, 25, 20, 21, 18/ +data (yyact(i),i=169,176) / 19, 3, 17, 14, 0, 0, 6, 7/ +data (yyact(i),i=177,184) / 8, 9, 10, 11, 4, 0, 0, 0/ +data (yyact(i),i=185,192) / 14, 0, 13, 6, 7, 8, 9, 10/ +data (yyact(i),i=193,200) / 11, 4, 12, 0, 0, 14, 0, 13/ +data (yyact(i),i=201,208) / 6, 7, 8, 9, 10, 11, 0, 12/ +data (yyact(i),i=209,216) / 5, 0, 0, 0, 13, 16, 0, 0/ +data (yyact(i),i=217,224) / 0, 0, 0, 0, 12, 32, 33, 34/ +data (yyact(i),i=225,232) / 0, 0, 36, 37, 38, 39, 40, 41/ +data (yyact(i),i=233,240) / 42, 43, 44, 45, 46, 47, 48, 49/ +data (yyact(i),i=241,248) / 50, 0, 0, 0, 52, 0, 0, 0/ +data (yyact(i),i=249,256) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=257,264) / 0, 0, 0, 0, 0, 0, 0, 56/ +short yypact[59] +data (yypact(i),i= 1, 8) / -87,-1000,-256,-1000, -61,-139,-1000,-1000/ +data (yypact(i),i= 9, 16) /-1000,-1000,-229,-247, -61, -61, -61,-1000/ +data (yypact(i),i= 17, 24) /-154, -61, -61, -61, -61, -61, -61, -61/ +data (yypact(i),i= 25, 32) / -61, -61, -61, -61, -61, -61, -61, -61/ +data (yypact(i),i= 33, 40) /-276,-115,-170, -61,-276,-276,-276,-216/ +data (yypact(i),i= 41, 48) /-216,-238,-238,-238,-238,-275,-275,-115/ +data (yypact(i),i= 49, 56) /-127,-195,-220,-1000,-244,-1000, -61, -74/ +data (yypact(i),i= 57, 59) /-259,-1000,-1000/ +short yypgo[4] +data (yypgo(i),i= 1, 4) / 0, 46, 74, 208/ +short yyr1[27] +data (yyr1(i),i= 1, 8) / 0, 1, 1, 2, 2, 3, 3, 3/ +data (yyr1(i),i= 9, 16) / 3, 3, 3, 3, 3, 3, 3, 3/ +data (yyr1(i),i= 17, 24) / 3, 3, 3, 3, 3, 3, 3, 3/ +data (yyr1(i),i= 25, 27) / 3, 3, 3/ +short yyr2[27] +data (yyr2(i),i= 1, 8) / 0, 2, 1, 6, 1, 1, 1, 1/ +data (yyr2(i),i= 9, 16) / 1, 4, 6, 2, 2, 3, 3, 3/ +data (yyr2(i),i= 17, 24) / 3, 3, 3, 3, 3, 3, 3, 3/ +data (yyr2(i),i= 25, 27) / 3, 3, 3/ +short yychk[59] +data (yychk(i),i= 1, 8) /-1000, -1, -2, 256, 267, -3, 261, 262/ +data (yychk(i),i= 9, 16) / 263, 264, 265, 266, 281, 273, 258, 270/ +data (yychk(i),i= 17, 24) / -3, 285, 282, 283, 280, 281, 276, 277/ +data (yychk(i),i= 25, 32) / 278, 279, 274, 275, 272, 271, 258, 258/ +data (yychk(i),i= 33, 40) / -3, -3, -3, 268, -3, -3, -3, -3/ +data (yychk(i),i= 41, 48) / -3, -3, -3, -3, -3, -3, -3, -3/ +data (yychk(i),i= 49, 56) / -3, -3, -3, 259, -3, 259, 260, 269/ +data (yychk(i),i= 57, 59) / -3, -2, 259/ +short yydef[59] +data (yydef(i),i= 1, 8) / 0, -2, 0, 2, 0, 4, 5, 6/ +data (yydef(i),i= 9, 16) / 7, 8, 0, 0, 0, 0, 0, 1/ +data (yydef(i),i= 17, 24) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yydef(i),i= 25, 32) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yydef(i),i= 33, 40) / 11, 12, 0, 0, 13, 14, 15, 16/ +data (yydef(i),i= 41, 48) / 17, -2, -2, -2, -2, -2, -2, 24/ +data (yydef(i),i= 49, 56) / 25, 0, 0, 26, 0, 9, 0, 0/ +data (yydef(i),i= 57, 59) / 0, 3, 10/ + +begin + call smark (yysp) + call salloc (yyv, (YYMAXDEPTH+2) * YYOPLEN, TY_STRUCT) + + # Initialization. The first element of the dynamically allocated + # token value stack (yyv) is used for yyval, the second for yylval, + # and the actual stack starts with the third element. + + yystate = 0 + yychar = -1 + yynerrs = 0 + yyerrflag = 0 + yyps = 0 + yyval = yyv + yylval = yyv + YYOPLEN + yypv = yylval + +yystack_ + # SHIFT -- Put a state and value onto the stack. The token and + # value stacks are logically the same stack, implemented as two + # separate arrays. + + if (yydebug) { + call printf ("state %d, char 0%o\n") + call pargs (yystate) + call pargi (yychar) + } + yyps = yyps + 1 + yypv = yypv + YYOPLEN + if (yyps > YYMAXDEPTH) { + call sfree (yysp) + call eprintf ("yacc stack overflow\n") + return (ERR) + } + yys[yyps] = yystate + YYMOVE (yyval, yypv) + +yynewstate_ + # Process the new state. + yyn = yypact[yystate+1] + + if (yyn <= YYFLAG) + goto yydefault_ # simple state + + # The variable "yychar" is the lookahead token. + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + yyn = yyn + yychar + if (yyn < 0 || yyn >= YYLAST) + goto yydefault_ + + yyn = yyact[yyn+1] + if (yychk[yyn+1] == yychar) { # valid shift + yychar = -1 + YYMOVE (yylval, yyval) + yystate = yyn + if (yyerrflag > 0) + yyerrflag = yyerrflag - 1 + goto yystack_ + } + +yydefault_ + # Default state action. + + yyn = yydef[yystate+1] + if (yyn == -2) { + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + + # Look through exception table. + yyxi = 1 + while ((yyexca[yyxi] != (-1)) || (yyexca[yyxi+1] != yystate)) + yyxi = yyxi + 2 + for (yyxi=yyxi+2; yyexca[yyxi] >= 0; yyxi=yyxi+2) { + if (yyexca[yyxi] == yychar) + break + } + + yyn = yyexca[yyxi+1] + if (yyn < 0) { + call sfree (yysp) + return (OK) # ACCEPT -- all done + } + } + + + # SYNTAX ERROR -- resume parsing if possible. + + if (yyn == 0) { + switch (yyerrflag) { + case 0, 1, 2: + if (yyerrflag == 0) { # brand new error + call eprintf ("syntax error\n") +yyerrlab_ + yynerrs = yynerrs + 1 + # fall through... + } + + # case 1: + # case 2: incompletely recovered error ... try again + yyerrflag = 3 + + # Find a state where "error" is a legal shift action. + while (yyps >= 1) { + yyn = yypact[yys[yyps]+1] + YYERRCODE + if ((yyn >= 0) && (yyn < YYLAST) && + (yychk[yyact[yyn+1]+1] == YYERRCODE)) { + # Simulate a shift of "error". + yystate = yyact[yyn+1] + goto yystack_ + } + yyn = yypact[yys[yyps]+1] + + # The current yyps has no shift on "error", pop stack. + if (yydebug) { + call printf ("error recovery pops state %d, ") + call pargs (yys[yyps]) + call printf ("uncovers %d\n") + call pargs (yys[yyps-1]) + } + yyps = yyps - 1 + yypv = yypv - YYOPLEN + } + + # ABORT -- There is no state on the stack with an error shift. +yyabort_ + call sfree (yysp) + return (ERR) + + + case 3: # No shift yet; clobber input char. + + if (yydebug) { + call printf ("error recovery discards char %d\n") + call pargi (yychar) + } + + if (yychar == 0) + goto yyabort_ # don't discard EOF, quit + yychar = -1 + goto yynewstate_ # try again in the same state + } + } + + + # REDUCE -- Reduction by production yyn. + + if (yydebug) { + call printf ("reduce %d\n") + call pargs (yyn) + } + yyps = yyps - yyr2[yyn+1] + yypvt = yypv + yypv = yypv - yyr2[yyn+1] * YYOPLEN + YYMOVE (yypv + YYOPLEN, yyval) + yym = yyn + + # Consult goto table to find next state. + yyn = yyr1[yyn+1] + yyj = yypgo[yyn+1] + yys[yyps] + 1 + if (yyj >= YYLAST) + yystate = yyact[yypgo[yyn+1]+1] + else { + yystate = yyact[yyj+1] + if (yychk[yystate+1] != -yyn) + yystate = yyact[yypgo[yyn+1]+1] + } + + # Perform action associated with the grammar rule, if any. + switch (yym) { + +case 1: +# line 34 "vexcompile.y" +{ + # Normal exit. Code a stop instruction + call vex_addcode (Y_DONE) + return (OK) + } +case 2: +# line 39 "vexcompile.y" +{ + return (ERR) + } +case 3: +# line 44 "vexcompile.y" +{ + # Code an if instruction + call vex_addcode (Y_IF) + } +case 4: +# line 48 "vexcompile.y" +{ + # Null action + } +case 5: +# line 53 "vexcompile.y" +{ + # Code a push variable instruction + call vex_addcode (Y_VAR) + call vex_addstr (Memi[yypvt]) + } +case 6: +# line 58 "vexcompile.y" +{ + # Code a push variable instruction + call vex_addcode (Y_INT) + call vex_addstr (Memi[yypvt]) + } +case 7: +# line 63 "vexcompile.y" +{ + # Code a push variable instruction + call vex_addcode (Y_REAL) + call vex_addstr (Memi[yypvt]) + } +case 8: +# line 68 "vexcompile.y" +{ + # Code a push variable instruction + call vex_addcode (Y_DOUBLE) + call vex_addstr (Memi[yypvt]) + } +case 9: +# line 73 "vexcompile.y" +{ + # Code a single argument function call + call vex_addcode (Y_FN1) + call vex_addstr (Memi[yypvt-3*YYOPLEN]) + } +case 10: +# line 78 "vexcompile.y" +{ + # Code a double argument function call + call vex_addcode (Y_FN2) + call vex_addstr (Memi[yypvt-5*YYOPLEN]) + } +case 11: +# line 83 "vexcompile.y" +{ + # Code a negation instruction + call vex_addcode (Y_NEG) + } +case 12: +# line 87 "vexcompile.y" +{ + # Code a logical not + call vex_addcode (Y_NOT) + } +case 13: +# line 91 "vexcompile.y" +{ + # Code an exponentiation instruction + call vex_addcode (Y_POW) + } +case 14: +# line 95 "vexcompile.y" +{ + # Code a multiply instruction + call vex_addcode (Y_MUL) + } +case 15: +# line 99 "vexcompile.y" +{ + # Code a divide instruction + call vex_addcode (Y_DIV) + } +case 16: +# line 103 "vexcompile.y" +{ + # Code an addition instruction + call vex_addcode (Y_ADD) + } +case 17: +# line 107 "vexcompile.y" +{ + # Code a subtraction instruction + call vex_addcode (Y_SUB) + } +case 18: +# line 111 "vexcompile.y" +{ + # Code a less than instruction + call vex_addcode (Y_LT) + } +case 19: +# line 115 "vexcompile.y" +{ + # Code a greater than instruction + call vex_addcode (Y_GT) + } +case 20: +# line 119 "vexcompile.y" +{ + # Code a less than or equal instruction + call vex_addcode (Y_LE) + } +case 21: +# line 123 "vexcompile.y" +{ + # Code a greater than instruction + call vex_addcode (Y_GE) + } +case 22: +# line 127 "vexcompile.y" +{ + # Code a logical equality instruction + call vex_addcode (Y_EQ) + } +case 23: +# line 131 "vexcompile.y" +{ + # Code a logical inequality instruction + call vex_addcode (Y_NE) + } +case 24: +# line 135 "vexcompile.y" +{ + # Code a logical and instruction + call vex_addcode (Y_AND) + } +case 25: +# line 139 "vexcompile.y" +{ + # Code a logical or instruction + call vex_addcode (Y_OR) + } +case 26: +# line 143 "vexcompile.y" +{ + # Null action + } } + + goto yystack_ # stack new state and value +end diff --git a/pkg/utilities/nttools/stxtools/vexcompile.y b/pkg/utilities/nttools/stxtools/vexcompile.y new file mode 100644 index 00000000..4b2cd958 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexcompile.y @@ -0,0 +1,616 @@ +%{ + +include <lexnum.h> +include <ctype.h> +include <fset.h> +include "vex.h" + +define YYMAXDEPTH 64 +define YYOPLEN 1 +define yyparse vex_parse + +# Tokens generated by xyacc have been moved to vex.h + +%L + +%} + +%token Y_WRONG Y_LPAR Y_RPAR Y_COMMA +%token Y_VAR Y_INT Y_REAL Y_DOUBLE +%token Y_FN1 Y_FN2 Y_IF Y_THEN Y_ELSE Y_DONE + +%left Y_OR +%left Y_AND +%right Y_NOT +%nonassoc Y_EQ Y_NE +%nonassoc Y_LT Y_GT Y_LE Y_GE +%left Y_ADD Y_SUB +%left Y_MUL Y_DIV +%right Y_NEG +%right Y_POW + +%% + +stmt : ifexpr Y_DONE { + # Normal exit. Code a stop instruction + call vex_addcode (Y_DONE) + return (OK) + } + | error { + return (ERR) + } + ; + +ifexpr : Y_IF expr Y_THEN expr Y_ELSE ifexpr { + # Code an if instruction + call vex_addcode (Y_IF) + } + | expr { + # Null action + } + ; + +expr : Y_VAR { + # Code a push variable instruction + call vex_addcode (Y_VAR) + call vex_addstr (Memi[$1]) + } + | Y_INT { + # Code a push variable instruction + call vex_addcode (Y_INT) + call vex_addstr (Memi[$1]) + } + | Y_REAL { + # Code a push variable instruction + call vex_addcode (Y_REAL) + call vex_addstr (Memi[$1]) + } + | Y_DOUBLE { + # Code a push variable instruction + call vex_addcode (Y_DOUBLE) + call vex_addstr (Memi[$1]) + } + | Y_FN1 Y_LPAR expr Y_RPAR { + # Code a single argument function call + call vex_addcode (Y_FN1) + call vex_addstr (Memi[$1]) + } + | Y_FN2 Y_LPAR expr Y_COMMA expr Y_RPAR { + # Code a double argument function call + call vex_addcode (Y_FN2) + call vex_addstr (Memi[$1]) + } + | Y_SUB expr %prec Y_NEG { + # Code a negation instruction + call vex_addcode (Y_NEG) + } + | Y_NOT expr { + # Code a logical not + call vex_addcode (Y_NOT) + } + | expr Y_POW expr { + # Code an exponentiation instruction + call vex_addcode (Y_POW) + } + | expr Y_MUL expr { + # Code a multiply instruction + call vex_addcode (Y_MUL) + } + | expr Y_DIV expr { + # Code a divide instruction + call vex_addcode (Y_DIV) + } + | expr Y_ADD expr { + # Code an addition instruction + call vex_addcode (Y_ADD) + } + | expr Y_SUB expr { + # Code a subtraction instruction + call vex_addcode (Y_SUB) + } + | expr Y_LT expr { + # Code a less than instruction + call vex_addcode (Y_LT) + } + | expr Y_GT expr { + # Code a greater than instruction + call vex_addcode (Y_GT) + } + | expr Y_LE expr { + # Code a less than or equal instruction + call vex_addcode (Y_LE) + } + | expr Y_GE expr { + # Code a greater than instruction + call vex_addcode (Y_GE) + } + | expr Y_EQ expr { + # Code a logical equality instruction + call vex_addcode (Y_EQ) + } + | expr Y_NE expr { + # Code a logical inequality instruction + call vex_addcode (Y_NE) + } + | expr Y_AND expr { + # Code a logical and instruction + call vex_addcode (Y_AND) + } + | expr Y_OR expr { + # Code a logical or instruction + call vex_addcode (Y_OR) + } + | Y_LPAR expr Y_RPAR { + # Null action + } + ; + +%% + +# VEX_COMPILE -- Compile an expression, producing pseudocode +# +# This procedure takes a string containing a fortran expression and produces +# pseudocode that can be evaluated by vex_eval(). The pseudocode is stored in +# structure adressed by the pointer returned as the function value. This +# structure is freed by calling vex_free(). If the string begins with an @ +# symbol, the rest of the string is treated as a the name of a file which +# contains the expression. The expression can contain all the fortran +# operators, including logical and relational operators and supports all the +# fortran intrinsic functions which can take real arguments. It also supports +# conditional expressions of the form: if <expr> then <expr> else <expr> +# Variables must follow the fortran rules, and may be up to 31 characters long. +# All variables and constants are treated as real numbers. A variable may +# contain non-alphanumeric characters if it is preceded by a dollar sign, in +# which case all characters until the next blank are part of the variable name. +# +# B.Simon 21-May-90 Original +# B.Simon 19-Apr-91 Revised to handle multiple types +# B.Simon 31-Mar-94 Better syntax error message +# B.Simon 15-Oct-98 Embed strings in pseudocode + +pointer procedure vex_compile (expr) + +char expr[ARB] # i: Expression to be parsed +#-- +include "vex.com" + +int ic, fd, len +bool debug +pointer sp, pcode + +data debug / false / + +int open(), stropen(), strlen(), fstati(), yyparse() + +int vex_gettok () +extern vex_gettok + +begin + # Open the expression as a file + + for (ic = 1; IS_WHITE(expr[ic]); ic = ic + 1) + ; + + if (expr[ic] == '@') { + fd = open (expr[ic+1], READ_ONLY, TEXT_FILE) + len = fstati (fd, F_FILESIZE) + 1 + + } else { + len = strlen (expr[ic]) + 1 + fd = stropen (expr[ic], len, READ_ONLY) + } + + # Create pseudocode structure + + call malloc (pcode, SZ_VEXSTRUCT, TY_STRUCT) + + call malloc (VEX_CODE(pcode), 2 * len, TY_INT) + call stk_init (VEX_STACK(pcode)) + + # Initialize parsing common block + + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + ch = line + Memc[line] = EOS + + ncode = 0 + maxcode = 2 * len + code = VEX_CODE(pcode) + stack = VEX_STACK(pcode) + + # Parse expression to produce reverse polish code + + if (yyparse (fd, debug, vex_gettok) == ERR) { + call eprintf ("%s\n%*t^\n") + call pargstr (Memc[line]) + call pargi (ch-line) + + call error (1, "Syntax error in expression") + } + + # Clean up and return pseudocode structure + + call stk_clear (VEX_STACK(pcode)) + + call close (fd) + call sfree (sp) + return (pcode) +end + +# VEX_GETTOK -- Get the next token from the input + +int procedure vex_gettok (fd, value) + +int fd # i: File containing expression to be lexed +pointer value # o: Address on parse stack to store token +#-- +include "vex.com" + +double constant +int ic, jc, nc, type, index +int idftype[4], keytype[3], btype[9] +pointer sp, errmsg, token + +string fn1tok FN1STR +string fn2tok FN2STR + +string idftok "indefi indefr indefd indef" +data idftype / Y_INT, Y_REAL, Y_DOUBLE, Y_REAL / + +string keytok "if then else" +data keytype / Y_IF, Y_THEN, Y_ELSE / + +string btoken ".or. .and. .eq. .ne. .lt. .gt. .le. .ge. .not." +data btype / Y_OR, Y_AND, Y_EQ, Y_NE, Y_LT, Y_GT, Y_LE, Y_GE, Y_NOT / + +string badsymb "Operator not recognized (%s)" + +int getline(), lexnum(), ctod(), stridxs(), word_match() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call malloc (token, MAX_TOKEN, TY_CHAR) + + # Skip over leading white space and comments + + while (Memc[ch] <= BLANK || Memc[ch] == CMTCHAR) { + + # If all characters have been read from the current line + # or a comment character was found, get the next line + + if (Memc[ch] == EOS || Memc[ch] == CMTCHAR) { + ch = line + if (getline (fd, Memc[line]) == EOF) { + Memc[ch] = EOS + break + } + } else { + ch = ch + 1 + } + } + + # The token type is determined from the first character in the token + + Memc[token] = EOS + + # End of expression token + + if (Memc[ch] == EOS) { + type = Y_DONE + + # Numeric constant is too difficult to parse, + # Pass the job to lexnum and ctod + + } else if (IS_DIGIT(Memc[ch])) { + + ic = 1 + index = lexnum (Memc[ch], ic, nc) + if (index != LEX_REAL) { + type = Y_INT + } else if (nc > 8) { + type = Y_DOUBLE + } else { + jc = stridxs ("dD", Memc[ch]) + if (jc == 0 || jc > nc) { + type = Y_REAL + } else { + type = Y_DOUBLE + } + } + + ic = 1 + nc = ctod (Memc[ch], ic, constant) + nc = min (nc, MAX_TOKEN) + + call strcpy (Memc[ch], Memc[token], nc) + ch = ch + ic - 1 + + # Token is alphanumeric. Determine what type of token + + } else if (IS_ALPHA (Memc[ch])) { + + # Gather characters in token + + for (ic = 1; ic <= MAX_TOKEN; ic = ic + 1) { + if (Memc[ch] != '_' && ! IS_ALNUM(Memc[ch])) + break + + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + Memc[token+ic-1] = EOS + + # Check to see if token is string "INDEF" + + index = word_match (Memc[token], idftok) + + if (index > 0) { + type = idftype[index] + call strupr (Memc[token]) + + } else { + + # Check to see if token is function or keyword name + # If not, add it as a new variable + + index = word_match (Memc[token], fn1tok) + if (index > 0) { + type = Y_FN1 + + } else { + index = word_match (Memc[token], fn2tok) + if (index > 0) { + type = Y_FN2 + + } else { + index = word_match (Memc[token], keytok) + if (index > 0) { + type = keytype[index] + Memc[token] = EOS + } else { + type = Y_VAR + } + } + } + } + + # Tokens beginning with a dot are numbers or boolean operators + + } else if (Memc[ch] == DOT) { + + if (IS_DIGIT (Memc[ch+1])) { + ic = 1 + index = lexnum (Memc[ch], ic, nc) + + if (index != LEX_REAL) { + type = Y_INT + } else if (nc < 9) { + type = Y_REAL + } else { + type = Y_DOUBLE + } + + ic = 1 + nc = ctod (Memc[ch], ic, constant) + nc = min (nc, MAX_TOKEN) + + call strcpy (Memc[ch], Memc[token], nc) + ch = ch + ic - 1 + + } else { + + # Gather characters in token + + ch = ch + 1 + Memc[token] = DOT + for (ic = 2; ic < MAX_TOKEN && Memc[ch] != DOT; ic = ic + 1) { + if (Memc[ch] == EOS) + break + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + + Memc[token+ic-1] = Memc[ch] + Memc[token+ic] = EOS + ch = ch + 1 + + index = word_match (Memc[token], btoken) + if (type > 0) { + type = btype[index] + } else { + call sprintf (Memc[errmsg], SZ_LINE, badsymb) + call pargstr (Memc[token]) + call error (1, Memc[errmsg]) + } + } + + # Characters preceded by a dollar sign are identifiers + + } else if (Memc[ch] == DOLLAR) { + + ch = ch + 1 + for (ic = 1; ic <= MAX_TOKEN && Memc[ch] > BLANK; ic = ic + 1) { + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + Memc[token+ic-1] = EOS + + type = Y_VAR + + # Anything else is a symbol + + } else { + switch (Memc[ch]) { + case '*': + if (Memc[ch+1] != '*') { + type = Y_MUL + } else { + type = Y_POW + ch = ch + 1 + } + case '/': + type = Y_DIV + case '+': + type = Y_ADD + case '-': + type = Y_SUB + case '(': + type = Y_LPAR + case ')': + type = Y_RPAR + case ',': + type = Y_COMMA + case '<': + if (Memc[ch+1] != '=') { + type = Y_LT + } else { + type = Y_LE + ch = ch + 1 + } + case '>': + if (Memc[ch+1] != '=') { + type = Y_GT + } else { + type = Y_GE + ch = ch + 1 + } + case '|': + if (Memc[ch+1] != '|') { + type = Y_WRONG + } else { + type = Y_OR + ch = ch + 1 + } + case '&': + if (Memc[ch+1] != '&') { + type = Y_WRONG + } else { + type = Y_AND + ch = ch + 1 + } + case '=': + if (Memc[ch+1] != '=') { + type = Y_WRONG + } else { + type = Y_EQ + ch = ch + 1 + } + case '!': + if (Memc[ch+1] != '=') { + type = Y_NOT + } else { + type = Y_NE + ch = ch + 1 + } + default: + Memc[ch+1] = EOS + call sprintf (Memc[errmsg], SZ_LINE, badsymb) + call pargstr (Memc[ch]) + call error (1, Memc[errmsg]) + } + + ch = ch + 1 + } + + # + if (Memc[token] == EOS) { + call mfree (token, TY_CHAR) + token = NULL + } + + Memi[value] = token + return (type) +end + +# VEX_ADDCODE -- Add an instruction to the code array + +procedure vex_addcode (type) + +int type # i: Instruction type +#-- +include "vex.com" + +begin + + if (ncode == maxcode) + call error (1, "Expression too complex") + else { + Memi[code] = type + code = code + 1 + ncode = ncode + 1 + } + +end + +# VEX_ADDSTR -- Embed a string constant in the pseudo-code + +procedure vex_addstr (token) + +pointer token # u: Pointer to token string +#-- +include "vex.com" + +int ic + +begin + if (token == NULL) + call error (1, "Expression token missing") + + if (Memc[token] == EOS) + call error (1, "Expression token blank") + + ic = 0 + repeat { + ic = ic + 1 + + if (ncode == maxcode) + call error (1, "Expression too complex") + else { + Memi[code] = Memc[token+ic-1] + code = code + 1 + ncode = ncode + 1 + } + + } until (Memc[token+ic-1] == EOS) + + call mfree (token, TY_CHAR) +end + +# VEX_GETSTR -- Retrieve a token string from the pseudocode array + +procedure vex_getstr (op, token, maxch) + +pointer op # u: Location of token string in pseudocode +char token[ARB] # o: Token string +int maxch # i: Maximum length of token +#-- +int ic + +begin + # The token begins one position after op and is + # termminated by an EOS + + ic = 0 + repeat { + ic = ic + 1 + op = op + 1 + if (ic <= maxch) + token[ic] = Memi[op] + + } until (Memi[op] == EOS) + +end diff --git a/pkg/utilities/nttools/stxtools/vexeval.x b/pkg/utilities/nttools/stxtools/vexeval.x new file mode 100644 index 00000000..40b10fbd --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexeval.x @@ -0,0 +1,228 @@ +include "vex.h" + +# VEX_EVAL -- Evaluate the pseudocode +# +# This procedure evaluates the pseudocode produced by vex_compile(). Evaluation +# is performed on an entire vector at a time. The calling program must +# supply a subroutine which returns the vector associated with a variable name. +# The procedure is called as follows: call getvar(stack, name), where +# stack is a pointer to the stack structure and name is the variable name. +# This procedure should call stk_alloc(stack, len, type) passing it the stack +# pointer, the length of the new array, and the type of the new array. The +# pointer to the new array is returned as the function value. The procedure +# should then fill in the values in the array. Code is the pointer returned +# by vex_compile(). Nil is a value substituted for the result of an illegal +# operation, such as division by zero. Type is the data type of expression. +# To retrieve the results of the expression, call vex_copy[dir], which +# retrieves the result as a double, integer, or real array and clears the +# stack for the next call of vex_eval. +# +# B.Simon 21-May-90 Original +# B.Simon 24-Apr-91 Revised to handle multiple types +# B.Simon 15-Oct-98 Embed strings in pseudocode + +procedure vex_eval (code, getvar, nil, type) + +pointer code # i: Pointer to pseudocode structure +extern getvar # i: Function which returns a vector given a name +double nil # i: Nil value used to replace illegal ops +int type # o: Data type of expression +#-- +double junk +int len, toktype +pointer sp, token, errmsg, stack, op, var + +string fn1tok FN1STR +string fn2tok FN2STR + +int word_match +double vex_nilf() +errchk vex_push + +string badcode "vex_eval : Illegal opcode (%d)" +string badfunc "vex_eval : Illegal function name (%s)" + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (token, MAX_TOKEN, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Initialize the undefined operation function + + junk = vex_nilf (nil) + + # Execute each code token until stop token found + + stack = VEX_STACK(code) + for (op = VEX_CODE(code); Memi[op] != Y_DONE; op = op + 1) { + call pargi (Memi[op]) + + # Perform the indicated operation on the stack variables + + switch (Memi[op]) { + case Y_VAR, Y_INT, Y_REAL, Y_DOUBLE: + toktype = Memi[op] + call vex_getstr (op, Memc[token], MAX_TOKEN) + call vex_push (stack, getvar, toktype, Memc[token]) + + case Y_FN1: + call vex_getstr (op, Memc[token], MAX_TOKEN) + + switch (word_match (Memc[token], fn1tok)) { + case FN1_ABS: + call vex_abs (stack) + + case FN1_ACOS: + call vex_acos (stack) + + case FN1_ASIN: + call vex_asin (stack) + + case FN1_ATAN: + call vex_atan (stack) + + case FN1_COS: + call vex_cos (stack) + + case FN1_COSH: + call vex_cosh (stack) + + case FN1_CUBE: + call vex_cube (stack) + + case FN1_DOUBLE: + call vex_double (stack) + + case FN1_EXP: + call vex_exp (stack) + + case FN1_INT: + call vex_int (stack) + + case FN1_LOG: + call vex_log (stack) + + case FN1_LOG10: + call vex_log10 (stack) + + case FN1_NINT: + call vex_nint (stack) + + case FN1_REAL: + call vex_real (stack) + + case FN1_SIN: + call vex_sin (stack) + + case FN1_SINH: + call vex_sinh (stack) + + case FN1_SQR: + call vex_sqr (stack) + + case FN1_SQRT: + call vex_sqrt (stack) + + case FN1_TAN: + call vex_tan (stack) + + case FN1_TANH: + call vex_tanh (stack) + + default: + call sprintf (Memc[errmsg], SZ_LINE, badfunc) + call pargstr (Memc[token]) + call error (1, Memc[errmsg]) + } + + case Y_FN2: + call vex_getstr (op, Memc[token], MAX_TOKEN) + + switch (word_match (Memc[token], fn2tok)) { + case FN2_ATAN2: + call vex_atan2 (stack) + + case FN2_DIM: + call vex_dim (stack) + + case FN2_MAX: + call vex_max (stack) + + case FN2_MIN: + call vex_min (stack) + + case FN2_MOD: + call vex_mod (stack) + + case FN2_SIGN: + call vex_sig (stack) + + default: + call sprintf (Memc[errmsg], SZ_LINE, badfunc) + call pargstr (Memc[token]) + call error (1, Memc[errmsg]) + } + + case Y_IF: + call vex_if (stack) + + case Y_OR: + call vex_or (stack) + + case Y_AND: + call vex_and (stack) + + case Y_NOT: + call vex_not (stack) + + case Y_EQ: + call vex_eq (stack) + + case Y_NE: + call vex_ne (stack) + + case Y_LT: + call vex_lt (stack) + + case Y_GT: + call vex_gt (stack) + + case Y_LE: + call vex_le (stack) + + case Y_GE: + call vex_ge (stack) + + case Y_ADD: + call vex_add (stack) + + case Y_SUB: + call vex_sub (stack) + + case Y_MUL: + call vex_mul (stack) + + case Y_DIV: + call vex_div (stack) + + case Y_NEG: + call vex_neg (stack) + + case Y_POW: + call vex_pow (stack) + + default: + call sprintf (Memc[errmsg], SZ_LINE, badcode) + call pargs (Memi[op]) + call error (1, Memc[errmsg]) + } + } + + # Retrieve the result of the expression, + # but only return the type to the user + + call stk_fetch (stack, 1, var, len, type) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/vexfree.x b/pkg/utilities/nttools/stxtools/vexfree.x new file mode 100644 index 00000000..f98bee57 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexfree.x @@ -0,0 +1,22 @@ +include "vex.h" + +# VEX_FREE -- Free the pseudocode structure +# +# This procedure frees the structure created by vex_compile() and evaluated +# by vex_eval() +# +# B.Simon 21-May-90 Original +# B.Simon 19-Apr-91 Revised to handle multiple types + +procedure vex_free (code) + +pointer code # i: Pointer to pseudocode structure +#-- + +begin + call stk_free (VEX_STACK(code)) + + call mfree (VEX_CODE(code), TY_INT) + call mfree (code, TY_STRUCT) +end + diff --git a/pkg/utilities/nttools/stxtools/vexfunc.x b/pkg/utilities/nttools/stxtools/vexfunc.x new file mode 100644 index 00000000..b4e40ae6 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexfunc.x @@ -0,0 +1,2011 @@ +include <mach.h> +include "vex.h" + +define MAX_EXP (2.3 * MAX_EXPONENT) +define MIN_REAL 1.0e-20 +define MIN_DOUBLE 1.0d-20 + +# VEX_FUNC -- Miscelaneous procedures used by the vex expression evaluator. +# +# Mostly these functions implement single opcodes such as add, sin, and +# push. However, it also includes vex_copy[dir], which copies the array +# on the top of the stack into a user array and vex_errf, which returns +# the substitute value used when an opcode would return an undefined +# value. The only functions which should be called directly from a user's +# program are vex_copy[dir]. +# +# B.Simon 24-Apr-91 Original +# B.Simon 15-Oct-98 Rewrite vex_push to use embedded strings + +# VEX_ABS -- Absolute value function + +procedure vex_abs (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = abs (Memi[in+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = abs (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = abs (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_ACOS -- Arc cosine function + +procedure vex_acos (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] < -1 || Memi[in+i] > 1) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = acos (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] < -1.0 || Memr[in+i] > 1.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = acos (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] < -1.0 || Memd[in+i] > 1.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = acos (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_ADD -- Addition function + +procedure vex_add (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in[1]+i] + Memi[in[2]+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in[1]+i] + Memr[in[2]+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in[1]+i] + Memd[in[2]+i] + + } + + call stk_pop (stack, 2) +end + +# VEX_AND -- Logical and + +procedure vex_and (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] != 0 && Memi[in[2]+i] != 0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] != 0.0 && Memr[in[2]+i] != 0.0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] != 0.0 && Memd[in[2]+i] != 0.0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_ASIN -- Arc sine function + +procedure vex_asin (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] < -1 || Memi[in+i] > 1) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = asin (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] < -1.0 || Memr[in+i] > 1.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = asin (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] < -1.0 || Memd[in+i] > 1.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = asin (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_ATAN -- Arc tangent function with one argument + +procedure vex_atan (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memr[out+i] = atan (real (Memi[in+i])) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = atan (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = atan (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_ATAN2 -- Arc tangent function with two arguments + +procedure vex_atan2 (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] == 0 && Memi[in[2]+i] == 0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = atan2 (real (Memi[in[1]+i]), + real (Memi[in[2]+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] == 0.0 && Memr[in[2]+i] == 0.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = atan2 (Memr[in[1]+i], Memr[in[2]+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] == 0.0 && Memd[in[2]+i] == 0.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = atan2 (Memd[in[1]+i], Memd[in[2]+i]) + } + } + + } + + call stk_pop (stack, 2) +end + +# VEX_COPYD -- Copy the top element of the stack into a double array + +procedure vex_copyd (code, nullval, buffer, maxbuf) + +pointer code # i: Pseudocode structure pointer +double nullval # i: Value to substitute for nulls +double buffer[ARB] # o: Output array +int maxbuf # i: Length of buffer +#-- +int len, type, ibuf +pointer stack, var, nullbuf + +string badsize "Cannot copy more elements than stack contains" + +begin + stack = VEX_STACK(code) + call stk_get (stack, TOP, var, len, type) + + if (type != TY_DOUBLE) + call stk_coerce (stack, TOP, TY_DOUBLE, var) + + if (maxbuf <= len) { + do ibuf = 1, maxbuf { + buffer[ibuf] = Memd[var] + var = var + 1 + } + + } else if (len != 0) { + call error (1, badsize) + + } else { + do ibuf = 1, maxbuf + buffer[ibuf] = Memd[var] + } + + # Set the null value in the output array + + call stk_getnull (stack, nullbuf) + if (nullbuf != NULL) { + do ibuf = 1, maxbuf { + if (Memb[nullbuf]) + buffer[ibuf] = nullval + if (len > 0) + nullbuf = nullbuf + 1 + } + } + + call stk_clear (stack) +end + +# VEX_COPYI -- Copy the top element of the stack into an integer array + +procedure vex_copyi (code, nullval, buffer, maxbuf) + +pointer code # i: Pseudocode structure pointer +int nullval # i: Value to substitute for nulls +int buffer[ARB] # o: Output array +int maxbuf # i: Length of buffer +#-- +int len, type, ibuf +pointer stack, var, nullbuf + +string badsize "Cannot copy more elements than stack contains" + +begin + stack = VEX_STACK(code) + call stk_get (stack, TOP, var, len, type) + + if (type != TY_INT) + call stk_coerce (stack, TOP, TY_INT, var) + + if (maxbuf <= len) { + do ibuf = 1, maxbuf { + buffer[ibuf] = Memi[var] + var = var + 1 + } + + } else if (len != 0) { + call error (1, badsize) + + } else { + do ibuf = 1, maxbuf + buffer[ibuf] = Memi[var] + } + + # Set the null value in the output array + + call stk_getnull (stack, nullbuf) + if (nullbuf != NULL) { + do ibuf = 1, maxbuf { + if (Memb[nullbuf]) + buffer[ibuf] = nullval + if (len > 0) + nullbuf = nullbuf + 1 + } + } + + call stk_clear (stack) +end + +# VEX_COPYR -- Copy the top element of the stack into a real array + +procedure vex_copyr (code, nullval, buffer, maxbuf) + +pointer code # i: Pseudocode structure pointer +real nullval # i: Value to substitute for nulls +real buffer[ARB] # o: Output array +int maxbuf # i: Length of buffer +#-- +int len, type, ibuf +pointer stack, var, nullbuf + +string badsize "Cannot copy more elements than stack contains" + +begin + stack = VEX_STACK(code) + call stk_get (stack, TOP, var, len, type) + + if (type != TY_REAL) + call stk_coerce (stack, TOP, TY_REAL, var) + + if (maxbuf <= len) { + do ibuf = 1, maxbuf { + buffer[ibuf] = Memr[var] + var = var + 1 + } + + } else if (len != 0) { + call error (1, badsize) + + } else { + do ibuf = 1, maxbuf + buffer[ibuf] = Memr[var] + } + + # Set the null value in the output array + + call stk_getnull (stack, nullbuf) + if (nullbuf != NULL) { + do ibuf = 1, maxbuf { + if (Memb[nullbuf]) + buffer[ibuf] = nullval + if (len > 0) + nullbuf = nullbuf + 1 + } + } + + call stk_clear (stack) +end + +# VEX_COS -- Cosine function + +procedure vex_cos (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memr[out+i] = cos (real (Memi[in+i])) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = cos (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = cos (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_COSH -- Hyperbolic cosine function + +procedure vex_cosh (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = cosh (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = cosh (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] > MAX_EXP) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = cosh (Memd[in+i]) + } + } + } + + call stk_pop (stack, 1) +end + +# VEX_CUBE -- Third power + +procedure vex_cube (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in+i] * Memi[in+i] * Memi[in+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in+i] * Memr[in+i] * Memr[in+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in+i] * Memd[in+i] * Memd[in+i] + + } + + call stk_pop (stack, 1) +end + +# VEX_DIM -- Positive difference + +procedure vex_dim (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = dim (Memi[in[1]+i], Memi[in[2]+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = dim (Memr[in[1]+i], Memr[in[2]+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = dim (Memd[in[1]+i], Memd[in[2]+i]) + + } + + call stk_pop (stack, 2) +end + +# VEX_DIV -- Division function + +procedure vex_div (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[2]+i] == 0) { + Memi[out+i] = vex_errf (stack, i) + } else { + Memi[out+i] = Memi[in[1]+i] / Memi[in[2]+i] + } + } + case TY_REAL: + do i = 0, len-1 { + if (abs(Memr[in[2]+i]) < MIN_REAL) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = Memr[in[1]+i] / Memr[in[2]+i] + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (abs(Memd[in[2]+i]) < MIN_DOUBLE) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = Memd[in[1]+i] / Memd[in[2]+i] + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_DOUBLE -- Convert to double + +procedure vex_double (stack) + +pointer stack # u: Stack descriptor +#-- +pointer out + +begin + call stk_coerce (stack, TOP, TY_DOUBLE, out) + +end + +# VEX_EQ -- Logical equality + +procedure vex_eq (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] == Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] == Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] == Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_ERRF -- Called when a function cannot be evaluated + +double procedure vex_errf (stack, index) + +pointer stack # u: Stack descriptor +int index # i: Index to row with illegal operation +double nil # i: Value substituted for illegal operation +#-- +double substitute +double temp + +data substitute / 0.0 / + +double vex_nilf() + +begin + call stk_initnull (stack, false) + call stk_setnull (stack, index) + + return (substitute) + + entry vex_nilf (nil) + + temp = substitute + substitute = nil + return (temp) + +end + +# VEX_EXP -- Exponentiation function + +procedure vex_exp (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = exp (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = exp (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] > MAX_EXP) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = exp (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_GE -- Greater than or equal to function + +procedure vex_ge (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] >= Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] >= Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] >= Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_GT -- Greater than function + +procedure vex_gt (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] > Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] > Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] > Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_IF -- Conditional evaluation + +procedure vex_if (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, index, i +pointer out, in[3] + +int stk_pos() +pointer stk_alloc() + +begin + call stk_fetch (stack, 3, in, len, type) + index = stk_pos (stack, 3) + call stk_coerce (stack, index, TY_INT, in[1]) + + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] != 0) { + Memi[out+i] = Memi[in[2]+i] + } else { + Memi[out+i] = Memi[in[3]+i] + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memi[in[1]+i] != 0) { + Memr[out+i] = Memr[in[2]+i] + } else { + Memr[out+i] = Memr[in[3]+i] + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memi[in[1]+i] != 0) { + Memd[out+i] = Memd[in[2]+i] + } else { + Memd[out+i] = Memd[in[3]+i] + } + } + } + + call stk_pop (stack, 3) +end + +# VEX_INT -- Convert to integer + +procedure vex_int (stack) + +pointer stack # u: Stack descriptor +#-- +pointer out + +begin + call stk_coerce (stack, TOP, TY_INT, out) + +end + +# VEX_LE -- Less than or equal to function + +procedure vex_le (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] <= Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] <= Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] <= Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_LT -- Less than function + +procedure vex_lt (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] < Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] < Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] < Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_LOG -- Natural log function + +procedure vex_log (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] <= 0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = log (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] <= 0.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = log (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] <= 0.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = log (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_LOG10 -- Common log function + +procedure vex_log10 (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] <= 0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = log10 (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] <= 0.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = log10 (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] <= 0.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = log10 (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_MAX -- Maximum of two numbers + +procedure vex_max (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = max (Memi[in[1]+i], Memi[in[2]+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = max (Memr[in[1]+i], Memr[in[2]+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = max (Memd[in[1]+i], Memd[in[2]+i]) + + } + + call stk_pop (stack, 2) +end + +# VEX_MIN -- Minimum of two numbers + +procedure vex_min (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = min (Memi[in[1]+i], Memi[in[2]+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = min (Memr[in[1]+i], Memr[in[2]+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = min (Memd[in[1]+i], Memd[in[2]+i]) + + } + + call stk_pop (stack, 2) +end + +# VEX_MOD -- Remainder function + +procedure vex_mod (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = mod (Memi[in[1]+i], Memi[in[2]+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = mod (Memr[in[1]+i], Memr[in[2]+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = mod (Memd[in[1]+i], Memd[in[2]+i]) + + } + + call stk_pop (stack, 2) +end + +# VEX_MUL -- Multiplication function + +procedure vex_mul (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in[1]+i] * Memi[in[2]+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in[1]+i] * Memr[in[2]+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in[1]+i] * Memd[in[2]+i] + + } + + call stk_pop (stack, 2) +end + +# VEX_NE -- Logical inequality + +procedure vex_ne (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] != Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] != Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] != Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_NEG -- Negation function + +procedure vex_neg (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = - Memi[in+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = - Memr[in+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = - Memd[in+i] + + } + + call stk_pop (stack, 1) +end + +# VEX_NINT -- Nearest integer + +procedure vex_nint (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer in, out + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = anint (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = anint (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_NOT -- Logical negation + +procedure vex_not (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] != 0) { + Memi[out+i] = 0 + } else { + Memi[out+i] = 1 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] != 0.0) { + Memi[out+i] = 0 + } else { + Memi[out+i] = 1 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] != 0.0) { + Memi[out+i] = 0 + } else { + Memi[out+i] = 1 + } + } + } + + call stk_pop (stack, 1) +end + +# VEX_OR -- Logical or + +procedure vex_or (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] != 0 || Memi[in[2]+i] != 0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] != 0.0 || Memr[in[2]+i] != 0.0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] != 0.0 || Memd[in[2]+i] != 0.0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_POW -- Exponentiation function + +procedure vex_pow (stack) + +pointer stack # u: Stack descriptor +#-- +double dtemp +int index, len, type, i +pointer out, in[2] +real rtemp + +double vex_errf() +int stk_pos() +pointer stk_alloc() + +begin + # If the exponent is an integer, use the normal exponentiation + # otherwise, use the logarithmic formulation + + call stk_get (stack, TOP, in[2], len, type) + + if (type == TY_INT) { + index = stk_pos (stack, 2) + call stk_get (stack, index, in[1], len, type) + + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in[1]+i] ** Memi[in[2]+i] + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in[1]+i] ** Memi[in[2]+i] + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in[1]+i] ** Memi[in[2]+i] + } + + } else { + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] <= 0.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + rtemp = Memr[in[2]+i] * log(Memr[in[1]+i]) + if (rtemp > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = exp (rtemp) + } + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] <= 0.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + dtemp = Memd[in[2]+i] * log(Memd[in[1]+i]) + if (dtemp > MAX_EXP) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = exp (dtemp) + } + } + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_PUSH -- Push a token onto the stack + +procedure vex_push (stack, getvar, type, token) + +pointer stack # i: Stack structure +extern getvar # i: Function to return a variable +int type # i: Token type +char token[ARB] # i: Token string +#-- +double dval +int len, ic, nc, ival +pointer sp, errmsg, var +real rval + +string badtype "Unrecognized token type (%d)" + +int ctoi(), ctor(), ctod() +pointer stk_alloc() +errchk getvar + +begin + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + len = STK_LENVAL(stack) + + switch (type) { + case Y_VAR: + call getvar (stack, token) + + case Y_INT: + var = stk_alloc (stack, len, TY_INT) + + ic = 1 + len = max (len, 1) + nc = ctoi (token, ic, ival) + call amovki (ival, Memi[var], len) + + case Y_REAL: + var = stk_alloc (stack, len, TY_REAL) + + ic = 1 + len = max (len, 1) + nc = ctor (token, ic, rval) + call amovkr (rval, Memr[var], len) + + case Y_DOUBLE: + var = stk_alloc (stack, len, TY_DOUBLE) + + ic = 1 + len = max (len, 1) + nc = ctod (token, ic, dval) + call amovkd (dval, Memd[var], len) + + default: + call sprintf (Memc[errmsg], SZ_LINE, badtype) + call pargi (type) + call error (1, Memc[errmsg]) + } + + call sfree (sp) +end + +# VEX_REAL -- Convert to real + +procedure vex_real (stack) + +pointer stack # u: Stack descriptor +#-- +pointer out + +begin + call stk_coerce (stack, TOP, TY_REAL, out) + +end + +# VEX_SIG -- Sign transfer function + +procedure vex_sig (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = sign (Memi[in[1]+i], Memi[in[2]+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = sign (Memr[in[1]+i], Memr[in[2]+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = sign (Memd[in[1]+i], Memd[in[2]+i]) + + } + + call stk_pop (stack, 2) +end + +# VEX_SIN -- Sine function + +procedure vex_sin (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memr[out+i] = sin (real (Memi[in+i])) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = sin (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = sin (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_SINH -- Hyperbolic sine function + +procedure vex_sinh (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = sinh (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = sinh (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] > MAX_EXP) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = sinh (Memd[in+i]) + } + } + } + + call stk_pop (stack, 1) +end + +# VEX_SQR -- Second power + +procedure vex_sqr (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in+i] * Memi[in+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in+i] * Memr[in+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in+i] * Memd[in+i] + + } + + call stk_pop (stack, 1) +end + +# VEX_SQRT -- Square root function + +procedure vex_sqrt (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] < 0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = sqrt (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] < 0.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = sqrt (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] < 0.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = sqrt (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_SUB -- Subtraction function + +procedure vex_sub (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in[1]+i] - Memi[in[2]+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in[1]+i] - Memr[in[2]+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in[1]+i] - Memd[in[2]+i] + + } + + call stk_pop (stack, 2) +end + +# VEX_TAN -- Tangent function + +procedure vex_tan (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memr[out+i] = tan (real (Memi[in+i])) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = tan (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = tan (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_TANH -- Hyperbolic tangent function + +procedure vex_tanh (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memr[out+i] = tanh (real (Memi[in+i])) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = tanh (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = tanh (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + + + + diff --git a/pkg/utilities/nttools/stxtools/vexstack.x b/pkg/utilities/nttools/stxtools/vexstack.x new file mode 100644 index 00000000..8f51b2bb --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexstack.x @@ -0,0 +1,585 @@ +include "vex.h" + +# VEX_STACK -- Procedures which manipulate the vex stack +# +# The expression evaluator, vex_eval, uses a stack to hold intermediate +# results, constants, and variable names in the expression. There are +# actually two stacks, a type stack wich contains the data types of the +# elements on the stack, and a value stack, which contains pointers to +# the stack elements. Constants and variable names are stored in two +# buffers which are part of the stack structure and pointers to their +# locations are placed on the stack. Intermediate results are stored in +# malloc'ed arrays and their pointers are also placed on the stack. The +# stack structure contains three indices, bottom, an index one greater +# than the last constant or variable name, top, an index that is one +# greater than the current top of stack, and high, an index that is one +# greater than the last valid pointer on the stack. Valid pointers exist +# beyond the top of stack because the arrays which store intermediate +# results are not mfree'd when the stack is popped, instead, they are +# kept in case they may be needed for a future intermediate result. The +# only user callable procedure in this file is stk_alloc, which should +# be called by getvar, the user's function which fills an array when +# passed the name of a variable. +# +# B.Simon 24-Apr-91 Original +# B.Simon 15-Oct-98 Store strings in pseudocode, not on stack + +# STK_ALLOC -- Allocate an array of the specified length and type + +pointer procedure stk_alloc (stack, len, type) + +pointer stack # i: Stack structure +int len # i: Length of array to allocate +int type # i: Data type of array (spp type) +#-- +int index, stype, top +pointer var, svar + +string badstack "stk_alloc: illegal type on stack" +string badsize "Requested array size does not match previous requests" + +errchk stk_find + +begin + # Check to see if array length is being defined for the first time + + if (STK_LENVAL(stack) == 0 && len != 0) { + + # Store length in stack structure + + STK_LENVAL(stack) = len + + # Free all stack arrays not currently being used + + index = STK_TOP(stack) + while (index < STK_HIGH(stack)) { + svar = STK_VALUE(stack,index) + stype = STK_TYPE(stack,index) + call mfree (svar, stype) + index = index + 1 + } + STK_HIGH(stack) = STK_TOP(stack) + + # Reallocate the null buffer + + if (STK_NULLARY(stack) != NULL) { + call stk_freenull (stack) + call stk_initnull (stack, true) + } + + # Convert length one arrays to their full length + + index = 0 + while (index < STK_TOP(stack)) { + svar = STK_VALUE(stack,index) + stype = STK_TYPE(stack,index) + + call malloc (var, len, stype) + STK_VALUE(stack,index) = var + switch (stype) { + case TY_INT,TY_LONG: + call amovki (Memi[svar], Memi[var], len) + call mfree (svar, TY_INT) + case TY_REAL: + call amovkr (Memr[svar], Memr[var], len) + call mfree (svar, TY_REAL) + case TY_DOUBLE: + call amovkd (Memd[svar], Memd[var], len) + call mfree (svar, TY_DOUBLE) + default: + call error (1, badstack) + } + index = index + 1 + } + } + + # Check requested size + + if (len != 0 && len != STK_LENVAL(stack)) + call error (1, badsize) + + # Look for an existing array of the same type + + call stk_find (stack, type, index) + + # Increment top of stack pointer + + top = STK_TOP(stack) + STK_TOP(stack) = top + 1 + + # Swap array with one currently at top of stack + + if (top != index) { + stype = STK_TYPE(stack,top) + STK_TYPE(stack,top) = STK_TYPE(stack,index) + STK_TYPE(stack,index) = stype + + svar = STK_VALUE(stack,top) + STK_VALUE(stack,top) = STK_VALUE(stack,index) + STK_VALUE(stack,index) = svar + } + + var = STK_VALUE(stack,top) + return (var) +end + +# STK_CLEAR -- Clear all stack elements above the bottom + +procedure stk_clear (stack) + +pointer stack # u: Stack pointer +#-- +int index + +begin + # Free all value arrays above the bottom of stack + + index = 0 + while (index < STK_HIGH(stack)) { + call mfree (STK_VALUE(stack,index), STK_TYPE(stack,index)) + index = index + 1 + } + + # Free null array + + call stk_freenull (stack) + + # Reset scalars + + STK_TOP(stack) = 0 + STK_HIGH(stack) = 0 + STK_LENVAL(stack) = 0 +end + +# STK_COERCE -- Coerce an array in the stack to the specified type + +procedure stk_coerce (stack, pos, type, var) + +pointer stack # i: Stack descriptor +int pos # i: Position of array in stack +int type # i: New type for array +pointer var # o: New pointer to array +#-- +int index, last, stype, len, i +pointer svar + +string underflow "stk_coerce: underflow in expression evaluator" + +errchk stk_find + +begin + # Convert relative to absolute position + + if (pos == TOP) { + index = STK_TOP(stack) - 1 + if (index < 0) + call error (1, underflow) + } else { + index = pos + } + + # If type of array matches requested type, return pointer to array + # Otherwise, get new array and copy old array to it + + if (type == STK_TYPE(stack,index)) { + var = STK_VALUE(stack,index) + + } else { + # Find array of correct type + + last = index + call stk_find (stack, type, index) + + # Copy array, converting to new type + + len = max (1, STK_LENVAL(stack)) + var = STK_VALUE(stack,index) + + stype = STK_TYPE(stack,last) + svar = STK_VALUE(stack,last) + + switch (type) { + case TY_INT,TY_LONG: + switch (stype) { + case TY_INT,TY_LONG: + ; # can't happen + case TY_REAL: + do i = 0, len-1 { + if (IS_INDEFR(Memr[svar+i])) { + Memi[var+i] = INDEFI + } else { + Memi[var+i] = Memr[svar+i] + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (IS_INDEFD(Memd[svar+i])) { + Memi[var+i] = INDEFI + } else { + Memi[var+i] = Memd[svar+i] + } + } + } + case TY_REAL: + switch (stype) { + case TY_INT,TY_LONG: + do i = 0, len-1 { + if (IS_INDEFI(Memi[svar+i])) { + Memr[var+i] = INDEFR + } else { + Memr[var+i] = Memi[svar+i] + } + } + case TY_REAL: + ; # can't happen + case TY_DOUBLE: + do i = 0, len-1 { + if (IS_INDEFD(Memd[svar+i])) { + Memr[var+i] = INDEFR + } else { + Memr[var+i] = Memd[svar+i] + } + } + } + case TY_DOUBLE: + switch (stype) { + case TY_INT,TY_LONG: + do i = 0, len-1 { + if (IS_INDEFI(Memi[svar+i])) { + Memd[var+i] = INDEFD + } else { + Memd[var+i] = Memi[svar+i] + } + } + case TY_REAL: + do i = 0, len-1 { + if (IS_INDEFR(Memr[svar+i])) { + Memd[var+i] = INDEFD + } else { + Memd[var+i] = Memr[svar+i] + } + } + case TY_DOUBLE: + ; # can't happen + } + } + + # Swap position of new and old arrays on stack + + STK_TYPE(stack,last) = STK_TYPE(stack,index) + STK_TYPE(stack,index) = stype + + STK_VALUE(stack,last) = STK_VALUE(stack,index) + STK_VALUE(stack,index) = svar + } + +end + +# STK_FETCH -- Fetch the specified number of arrays from the stack + +procedure stk_fetch (stack, nvar, var, len, type) + +pointer stack # i: Stack descriptor +int nvar # i: Number of pointers requested +pointer var[ARB] # o: Array pointers +int len # o: Length of arrays +int type # o: Type of arrays +#-- +int one, two, index, ivar + +string underflow "stk_fetch: underflow in expression evaluator" + +errchk stk_coerce + +begin + # If length is not yet defined, STK_LENVAL equals zero + + len = STK_LENVAL(stack) + + # Find the highest type in the pointers to be returned + + one = STK_TOP(stack) - 1 + two = STK_TOP(stack) - 2 + + type = STK_TYPE(stack,one) + if (nvar > 1) { + switch (STK_TYPE(stack,two)) { + case TY_INT, TY_LONG: + ; + case TY_REAL: + if (type == TY_INT) + type = TY_REAL + case TY_DOUBLE: + type = TY_DOUBLE + } + } + + # Retrieve pointers to arrays from stack. var[nvar] is top of stack + # Convert arrays to output type when the type differs + + index = STK_TOP(stack) - nvar + do ivar = 1, nvar { + if (index < 0) + call error (1, underflow) + + if (type == STK_TYPE(stack,index) || index < two) { + var[ivar] = STK_VALUE(stack,index) + } else { + call stk_coerce (stack, index, type, var[ivar]) + } + index = index + 1 + } + +end + +# STK_FIND -- Find a free array of the proper type on the stack + +procedure stk_find (stack, type, index) + +pointer stack # i: Stack descriptor +int type # i: Required type +int index # o: Position on the stack +#-- +int len +pointer var + +string overflow "Expression too complex to be evaluated" + +begin + # Try to find an array of the proper type already on the stack + + index = STK_TOP(stack) + while (index < STK_HIGH(stack)) { + if (type == STK_TYPE(stack,index)) + break + + index = index + 1 + } + + # If not found, allocate a new array + + if (index == MAX_STACK) { + call error (1, overflow) + + } else if (index == STK_HIGH(stack)) { + len = max (1, STK_LENVAL(stack)) + call malloc (var, len, type) + + STK_TYPE(stack,index) = type + STK_VALUE(stack,index) = var + STK_HIGH(stack) = STK_HIGH(stack) + 1 + } + +end + +# STK_FREE -- Free memory used by the stack + +procedure stk_free (stack) + +pointer stack # u: Stack pointer +#-- + +begin + # Free all values above the stack bottom + + call stk_clear (stack) + + # Free substructures in stack + + if (STK_NULLARY(stack) != NULL) + call mfree (STK_NULLARY(stack), TY_BOOL) + + call mfree (STK_VALARY(stack), TY_INT) + call mfree (STK_TYPARY(stack), TY_INT) + + # Free the stack structure + call mfree (stack, TY_INT) +end + +# STK_FREENULL -- Free the null array in the stack + +procedure stk_freenull (stack) + +pointer stack # u: Stack structure +#-- + +begin + if (STK_NULLARY(stack) != NULL) + call mfree (STK_NULLARY(stack), TY_BOOL) + + STK_NULLARY(stack) = NULL +end + +# STK_GET -- Get a single array from the stack + +procedure stk_get (stack, pos, var, len, type) + +pointer stack # i: Stack descriptor +int pos # i: Position on the stack +pointer var # o: Pointer to array +int len # o: Length of array +int type # o: Type of the array +#-- +int index + +string underflow "stk_get: underflow in expression evaluator" + +begin + # Convert relative to absolute position + + if (pos == TOP) { + index = STK_TOP(stack) - 1 + if (index < 0) + call error (1, underflow) + } else { + index = pos + } + + var = STK_VALUE(stack,index) + len = STK_LENVAL(stack) + type = STK_TYPE(stack,index) +end + +# STK_GETNULL -- Get the null array from the stack + +procedure stk_getnull (stack, nullvec) + +pointer stack # i: Stack structure +pointer nullvec # o: Null array +#-- + +begin + nullvec = STK_NULLARY(stack) +end + +# STK_INIT -- Initialize the stack + +procedure stk_init (stack) + +pointer stack # o: Stack pointer +#-- + +begin + # Allocate stack and initialize members to zero + + call calloc (stack, SZ_STKSTRUCT, TY_INT) + + # Allocate substructures in stack + + call malloc (STK_VALARY(stack), MAX_STACK, TY_INT) + call malloc (STK_TYPARY(stack), MAX_STACK, TY_INT) + +end + +# STK_INITNULL -- Initialize the null array on the stack + +procedure stk_initnull (stack, value) + +pointer stack # u: Stack structure +bool value # i: Value used in initialization +#-- +int len, i +pointer nullvec + +begin + # Only initialize if array doesn't exist + + if (STK_NULLARY(stack) == NULL) { + len = STK_LENVAL(stack) + + # Allocate array + call malloc (nullvec, len, TY_BOOL) + STK_NULLARY(stack) = nullvec + + # Initialize to value + do i = 0, len-1 + Memb[nullvec+i] = value + } + +end + +# STK_ORNULL -- Update null array by doing a logical or + +procedure stk_ornull (stack, newvec, newlen) + +pointer stack # u: Stack structure +bool newvec[ARB] # i: Array of new values +int newlen # i: Length of new array +#-- +int len, i +pointer nullvec + +string badlength "stk_ornull: length of array does not match null array" + +begin + len = STK_LENVAL(stack) + if (len != newlen) + call error (1, badlength) + + call stk_initnull (stack, false) + nullvec = STK_NULLARY(stack) + + do i = 1, len { + Memb[nullvec] = Memb[nullvec] || newvec[i] + nullvec = nullvec + 1 + } + +end + +# STK_POP -- Remove the specified number of arrays from the stack + +procedure stk_pop (stack, npop) + +pointer stack # u: Stack structure +int npop # i: Number of arrays to pop +#-- +int top, index, type +pointer var + +string underflow "stk_pop: underflow in expression evaluator" + +begin + + top = STK_TOP(stack) - 1 + index = top - npop + + if (index < 0) { + call error (1, underflow) + } else { + STK_TOP(stack) = index + 1 + } + + var = STK_VALUE(stack,index) + STK_VALUE(stack,index) = STK_VALUE(stack,top) + STK_VALUE(stack,top) = var + + type = STK_TYPE(stack,index) + STK_TYPE(stack,index) = STK_TYPE(stack,top) + STK_TYPE(stack,top) = type + +end + +# STK_POS -- Compute absolute position on stack + +int procedure stk_pos (stack, pos) + +pointer stack # i: Stack structure +int pos # i: Position relative to top of stack +#-- + +begin + return (STK_TOP(stack) - pos) +end + +# STK_SETNULL -- Set a single value in the null array to true + +procedure stk_setnull (stack, index) + +pointer stack # u: Stack structure +int index # i: Index into null array +#-- + +begin + STK_NULL(stack,index) = true +end + diff --git a/pkg/utilities/nttools/stxtools/wcslab/mkpkg b/pkg/utilities/nttools/stxtools/wcslab/mkpkg new file mode 100644 index 00000000..f5083925 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/mkpkg @@ -0,0 +1,17 @@ +# WCSLAB + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + wlutil.x <imio.h> <imhdr.h> <gset.h> <math.h> + wcslab.x <gset.h> <imhdr.h> <mwset.h> <math.h> "wcslab.h"\ + "wcs_desc.h" + wlwcslab.x <gio.h> <gset.h> "wcslab.h" "wcs_desc.h" + wlsetup.x <gset.h> <mach.h> <math.h> <math/curfit.h>\ + "wcslab.h" "wcs_desc.h" + wlgrid.x <gset.h> <math.h> "wcslab.h" "wcs_desc.h" + wllabel.x <gset.h> <math.h> "psiescape.h" "wcslab.h" "wcs_desc.h" + ; diff --git a/pkg/utilities/nttools/stxtools/wcslab/mkpkg.ori b/pkg/utilities/nttools/stxtools/wcslab/mkpkg.ori new file mode 100644 index 00000000..7108366c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/mkpkg.ori @@ -0,0 +1,18 @@ +# WCSLAB + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_wcslab.x <gset.h> <imhdr.h> + wlutil.x <imio.h> <imhdr.h> <gset.h> <math.h> + wcslab.x <gset.h> <imhdr.h> <mwset.h> <math.h> "wcslab.h"\ + "wcs_desc.h" + wlwcslab.x <gio.h> <gset.h> "wcslab.h" "wcs_desc.h" + wlsetup.x <gset.h> <mach.h> <math.h> <math/curfit.h>\ + "wcslab.h" "wcs_desc.h" + wlgrid.x <gset.h> <math.h> "wcslab.h" "wcs_desc.h" + wllabel.x <gset.h> <math.h> "wcslab.h" "wcs_desc.h" + ; diff --git a/pkg/utilities/nttools/stxtools/wcslab/psiescape.h b/pkg/utilities/nttools/stxtools/wcslab/psiescape.h new file mode 100644 index 00000000..46da4ea2 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/psiescape.h @@ -0,0 +1,80 @@ +.help psiescape.h 1May92 plot +.ih +.NAME +psiescape.h -- Define the special GIO escape instructions. +.ih +DESCRIPTION +The following escape instructions are defined for the PostScript GKI +Interpreter: + + PS_CODE - Send the raw PostScript code to the output. + PS_IMAGE_RED_LUT - Download a new lookup table for the Red component + of an image. + PS_IMAGE_GREEN_LUT - Download a new lookup table for the Green component + of an image. + PS_IMAGE_BLUE_LUT - Download a new lookup table for the Blue component + of an image. + PS_GR_RED_LUT - Download a new lookup table for the Red component + for the graphics. + PS_GR_GREEN_LUT - Download a new lookup table for the Green component + for the graphics. + PS_GR_BLUE_LUT - Download a new lookup table for the Blue component + for the graphics. + PS_ROMAN_FONT - Specify a new font for the normal font. + PS_GREEK_FONT - Specify a new font for the greek font. + PS_ITALIC_FONT - Specify a new font for the italic font. + PS_BOLD_FONT - Specify a new font for the bold font. + PS_VARIABLE_SPACE - Change whether characters are mono-spaced or + variable-spaced. + PS_DASH, PS_DOT, + PS_SPACE - Change the sizes of a dash, a dot, and the space + between them. + PS_FILL_PATTERN - Add/change fill patterns. + +The size of the instruction array should have the following minimums: + - For the PS_CODE instruction, the array should be the length of the string + being passed. + - The size of each image LUT array is PS_IMAGE_LUT_SIZE. + - The size of each graphics LUT array is PS_GR_LUT_SIZE. + - The font arrays should be the length of the string containing the name + of the font to use. + - For the PS_VARIABLE_SPACE, the size is PS_VARIABLE_SPACE_SIZE. + - For PS_FILL_PATTERN, the size is PS_FILL_SIZE. + +.ih +SEE ALSO +t_psikern +.endhelp +#--------------------------------------------------------------------------- + +# Define the escape instructions. +define PS_CODE 1001 +define PS_IMAGE_RED_LUT 1002 +define PS_IMAGE_GREEN_LUT 1003 +define PS_IMAGE_BLUE_LUT 1004 +define PS_GR_RED_LUT 1005 +define PS_GR_GREEN_LUT 1006 +define PS_GR_BLUE_LUT 1007 +define PS_ROMAN_FONT 1008 +define PS_GREEK_FONT 1009 +define PS_ITALIC_FONT 1010 +define PS_BOLD_FONT 1011 +define PS_VARIABLE_SPACE 1012 +define PS_DOT 1013 +define PS_DASH 1014 +define PS_SPACE 1015 +define PS_FILL_PATTERN 1016 +define PS_IMAGE_LUT 1017 +define PS_GRAPHICS_LUT 1018 + +# Define the sizes of the instruction arrays. +define PS_MAX_LUT_VALUE 255 +define PS_IMAGE_LUT_SIZE 256 +define PS_GR_LUT_SIZE 16 +define PS_VARIABLE_SPACE_SIZE 1 +define PS_FILL_SIZE 9 + +# Define how to pack/unpack a LUT defined as reals from 0-1 into +# a short array from 0-PS_MAX_LUT_VALUE. +define PS_PACKLUT (int($1*PS_MAX_LUT_VALUE)) +define PS_UNPACKLUT ($1/real(PS_MAX_LUT_VALUE)) diff --git a/pkg/utilities/nttools/stxtools/wcslab/t_wcslab.x b/pkg/utilities/nttools/stxtools/wcslab/t_wcslab.x new file mode 100644 index 00000000..acafdf2f --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/t_wcslab.x @@ -0,0 +1,136 @@ +include <gset.h> +include <imhdr.h> + +# T_WCSLAB -- Procedure to draw labels and grids in sky projection coordinates. +# +# Description +# T_wcslab produces a labelling and grid based on the MWCS of a +# specified image. This is the task interface to the programmer interface +# wcslab. See wcslab.x for more information. +# +# Bugs +# Can only handle sky projections for Right Ascension/Declination. This +# should be able to deal with any of the projections for this system, but +# has only been tested with the Tangent projection. +# + +procedure t_wcslab() + +pointer image # I: name of the image +int frame # I: display frame containing the image +bool do_fill # I: true if the graph fills the specified viewport +int mode # I: the graphics stream mode +pointer device # I: the name of the graphics device +real vl, vr, vb, vt # I: the edges of the graphics viewport + +pointer sp, title, gp, im, mw +real c1, c2, l1, l2 +bool clgetb() +int clgeti(), strncmp() +pointer gopen(), immap(), mw_openim() +real clgetr() + +begin + # Get memory. + call smark (sp) + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (title, SZ_LINE, TY_CHAR) + + # Since all the MWCS information comes from an image open it. + call clgstr ("image", Memc[image], SZ_FNAME) + + if (Memc[image] != EOS) { + + # Open the image. + im = immap (Memc[image], READ_ONLY, 0) + + # Quit if the image is not 2-dimensional. + if (IM_NDIM(im) != 2) { + call eprintf ("Image: %s is not 2-dimensional\n") + call pargstr (Memc[image]) + call sfree (sp) + return + } + + # Set the default input image column and line limits. + c1 = 1.0 + c2 = real (IM_LEN(im,1)) + l1 = 1.0 + l2 = real (IM_LEN(im,2)) + + # Open the WCS. + mw = mw_openim (im) + + # Set up the default image title. + call strcpy (Memc[image], Memc[title], SZ_LINE) + call strcat (": ", Memc[title], SZ_LINE) + call strcat (IM_TITLE(im), Memc[title], SZ_LINE) + + } else { + + # Set the image information to undefined. All this will + # be determined in wcslab. + Memc[title] = EOS + im = NULL + mw = NULL + c1 = 0.0 + c2 = 1.0 + l1 = 0.0 + l2 = 1.0 + } + + # Set the graphics mode depending on whether we are appending to a plot + # or starting a new plot. + do_fill = clgetb ("fill") + if (clgetb ("append")) + mode = APPEND + else + mode = NEW_FILE + + # Open graphics. + call clgstr ("device", Memc[device], SZ_FNAME) + + # If we are appending, get the previous viewing parameters. + if (mode == APPEND) { + + gp = gopen (Memc[device], APPEND, STDGRAPH) + call ggview (gp, vl, vr, vb, vt) + do_fill = true + + # If drawing on the image display device try to match viewports. + } else if (strncmp (Memc[device], "imd", 3) == 0) { + + frame = clgeti ("frame") + vl = clgetr ("vl") + vr = clgetr ("vr") + vb = clgetr ("vb") + vt = clgetr ("vt") + call wl_imd_viewport (frame, im, c1, c2, l1, l2, vl, vr, vb, vt) + gp = gopen (Memc[device], NEW_FILE, STDGRAPH) + + # Otherwise set up a standard viewport. + } else { + vl = clgetr ("vl") + vr = clgetr ("vr") + vb = clgetr ("vb") + vt = clgetr ("vt") + gp = gopen (Memc[device], NEW_FILE, STDGRAPH) + } + + # Set the viewport. + call gseti (gp, G_WCS, 1) + call wl_map_viewport (gp, c1, c2, l1, l2, vl, vr, vb, vt, do_fill) + + # All reading from CL parameters is now done. Everything necessary to + # do the plotting is in the WCSLAB descriptor. Do it. + call wcslab (mw, c1, c2, l1, l2, gp, Memc[title]) + + # Release the memory. + call gclose (gp) + if (mw != NULL) + call mw_close (mw) + if (im != NULL) + call imunmap (im) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/wcslab/wcs_desc.h b/pkg/utilities/nttools/stxtools/wcslab/wcs_desc.h new file mode 100644 index 00000000..4f6b2a30 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/wcs_desc.h @@ -0,0 +1,219 @@ +# WCS_DESC - The definition of the WCSLAB descriptor memory structure. +# +# Description +# This include file defines the memory structures and macros needed to +# access elements of a WCSLAB descriptor. The descriptor provides all +# the necessary elements for the routine wcslab to produce a labeled +# graph. +# +# History +# 9May91 - Created the descriptor. Jonathan D. Eisenhamer, STScI. +# 15May91 - Modified the descriptor to contain only pointers to arrays. +# Two routines, wcs_create and wcs_destroy are required to +# create the arrays that are pointed to in the descriptor. +# Also seperated the include file from the wcslab.h file. jde +# 12Jun91 - Rewrote some of the labelling parameters. jde +# 20Jun91 - Redesigned much of the parameters. jde +#--------------------------------------------------------------------------- + +# Value of opposite axis that polar labels should appear along. +define WL_POLAR_LABEL_POSITION Memd[P2D($1)] + +# The rotation between the Logical and World coordinate systems. +define WL_ROTA Memd[P2D($1+2)] + +# Size of the axis titles. +define WL_AXIS_TITLE_SIZE Memr[P2R($1+4)] + +# The offset required to properly calculate positions in the image display. +define WL_IMAGE_X_OFF Memr[P2R($1+5)] +define WL_IMAGE_Y_OFF Memr[P2R($1+6)] + +# Size of the grid labels. +define WL_LABEL_SIZE Memr[P2R($1+7)] + +# Major tick mark size. +define WL_MAJ_TICK_SIZE Memr[P2R($1+8)] + +# Minor tick mark size. +define WL_MIN_TICK_SIZE Memr[P2R($1+9)] + +# Magnification of the text size for the title. +define WL_TITLE_SIZE Memr[P2R($1+10)] + +# The side in polar/near-polar plots not to put Axis 1 labels. +define WL_BAD_LABEL_SIDE Memi[$1+11] + +# The type of graph that will be produced. The possible value are: +# +# UNKNOWN -> Graph type will be determined +# NORMAL -> Approximate a cartesian grid +# POLAR -> Graph center on a pole +# NEAR_POLAR -> Graph very close to a pole + +define WL_GRAPH_TYPE Memi[$1+12] + +# Number of segments each line should be broken into to plot it. +define WL_LINE_SEGMENTS Memi[$1+13] + +# The grid line type for major grids. The possible values are to standard +# IRAF GIO polyline types. +define WL_MAJ_LINE_TYPE Memi[$1+14] + +# The grid line type for minor grids. The possible values are to standard +# IRAF GIO polyline types. +define WL_MIN_LINE_TYPE Memi[$1+15] + +# The number of label points. +define WL_N_LABELS Memi[$1+16] + +# The graphic WCS that is set to NDC units. +define WL_NDC_WCS Memi[$1+17] + +# The graphic WCS used to plot the grid lines. +define WL_PLOT_WCS Memi[$1+18] + +# The direction of the latitude labelling on polar graphs. Possible values are: +# +# BOTTOM -> Towards the bottom of the graph. +# TOP -> Towards the top of the graph. +# RIGHT -> Towards the right of the graph. +# LEFT -> Towards the left of the graph. + +define WL_POLAR_LABEL_DIRECTION Memi[$1+19] + +# The possible axis types. The possible values are: +# +# RA_DEC_TAN - The tangential display in right ascension and declination. +# LINEAR - General linear systems. + +define WL_SYSTEM_TYPE Memi[$1+20] + +# Define which side of the graph will have the title. +define WL_TITLE_SIDE Memi[$1+21] + +# True if the axis mapping has reversed the order of the axis relative +# to the logical system. +define WL_AXIS_FLIP Memi[$1+22] + +# TRUE if the labels should always be printed in full form. +define WL_ALWAYS_FULL_LABEL Memi[$1+23] + +# TRUE if the grid labels should rotate with the grid lines. +define WL_LABEL_ROTATE Memi[$1+26] + +# True if coordinate labels are to be written. +define WL_LABON Memi[$1+27] + +# True if we are to write labels outside the window borders. Else, write +# them inside. +define WL_LABOUT Memi[$1+28] + +# True if we are to draw the major grid lines. +define WL_MAJ_GRIDON Memi[$1+29] + +# True if we are to draw the minor grid lines. +define WL_MIN_GRIDON Memi[$1+30] + +# True if the graph parameters should be written back out to the +# parameter file. +define WL_REMEMBER Memi[$1+31] + +# TRUE if tick marks should point into the graph. +define WL_TICK_IN Memi[$1+32] + +# Titles to label each axis. +define WL_AXIS_TITLE_PTR Memi[$1+33] +define WL_AXIS_TITLE Memc[WL_AXIS_TITLE_PTR($1)+(($2-1)*SZ_LINE)] + +# The sides the axis titles will appear. +define WL_AXIS_TITLE_SIDE_PTR Memi[$1+34] +define WL_AXIS_TITLE_SIDE Memi[WL_AXIS_TITLE_SIDE_PTR($1)+$2-1] + +# Beginning values to start labeling the axes. +define WL_BEGIN_PTR Memi[$1+35] +define WL_BEGIN Memd[WL_BEGIN_PTR($1)+$2-1] + +# The name of the graphics device. +#define WL_DEVICE_PTR Memi[$1+36] +#define WL_DEVICE Memc[WL_DEVICE_PTR($1)] + +# Value to stop labeling the axes. +define WL_END_PTR Memi[$1+37] +define WL_END Memd[WL_END_PTR($1)+$2-1] + +# The graphics descriptor. +define WL_GP Memi[$1+38] + +# The angle of text at this label point. +define WL_LABEL_ANGLE_PTR Memi[$1+40] +define WL_LABEL_ANGLE Memd[WL_LABEL_ANGLE_PTR($1)+$2-1] + +# Which axis the label represents. +define WL_LABEL_AXIS_PTR Memi[$1+41] +define WL_LABEL_AXIS Memi[WL_LABEL_AXIS_PTR($1)+$2-1] + +# The positions of tick mark/grid labels. +define WL_LABEL_POSITION_PTR Memi[$1+42] +define WL_LABEL_POSITION Memd[WL_LABEL_POSITION_PTR($1)+$2-1+(($3-1)*MAX_LABEL_POINTS)] +# +# NOTE: If the axis are transposed, the positions represented here are +# the corrected, transposed values. + +# The sides the labels for each axis should appear on. +define WL_LABEL_SIDE_PTR Memi[$1+43] +define WL_LABEL_SIDE Memb[WL_LABEL_SIDE_PTR($1)+$2-1+(($3-1)*N_SIDES)] + +# The value of the label. +define WL_LABEL_VALUE_PTR Memi[$1+44] +define WL_LABEL_VALUE Memd[WL_LABEL_VALUE_PTR($1)+$2-1] + +# The center of the transformations in the logical system. +define WL_LOGICAL_CENTER_PTR Memi[$1+45] +define WL_LOGICAL_CENTER Memd[WL_LOGICAL_CENTER_PTR($1)+$2-1] + +# The coordinate transformation from Logical to World. +define WL_LWCT Memi[$1+46] + +# Major grid intervals for the axis. +define WL_MAJ_I_PTR Memi[$1+47] +define WL_MAJOR_INTERVAL Memd[WL_MAJ_I_PTR($1)+$2-1] + +# The minor intervals for the axis. +define WL_MIN_I_PTR Memi[$1+48] +define WL_MINOR_INTERVAL Memi[WL_MIN_I_PTR($1)+$2-1] + +# Remember the extent of the labels around the plot box. +define WL_NV_PTR Memi[$1+49] +define WL_NEW_VIEW Memr[WL_NV_PTR($1)+$2-1] + +# The MWL structure. +define WL_MW Memi[$1+50] + +# The values of the sides of the screen. The indexes are defined as follows: +# +# TOP -> Y-axis value at the top of display. +# BOTTOM -> Y-axis value at bottom of display +# RIGHT -> X-axis value at right of display. +# LEFT -> X-axis value at left of display. +# +define WL_SCREEN_BOUNDARY_PTR Memi[$1+51] +define WL_SCREEN_BOUNDARY Memd[WL_SCREEN_BOUNDARY_PTR($1)+$2-1] + +# The title that will be placed on the plot. +define WL_TITLE_PTR Memi[$1+52] +define WL_TITLE Memc[WL_TITLE_PTR($1)] + +# The coordinate transformation from World to Logical. +define WL_WLCT Memi[$1+53] + +# The center of the transformations in the world system. +define WL_WORLD_CENTER_PTR Memi[$1+54] +define WL_WORLD_CENTER Memd[WL_WORLD_CENTER_PTR($1)+$2-1] + +# The length of this structure. +define WL_LEN 55+1 + +#--------------------------------------------------------------------------- +# End of wcs_desc +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/wcslab/wcslab.h b/pkg/utilities/nttools/stxtools/wcslab/wcslab.h new file mode 100644 index 00000000..cf088323 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/wcslab.h @@ -0,0 +1,98 @@ +# Definitions file for WCSLAB + +# Define various important dimensions + +define MAX_DIM 10 # Maximum number of dimensions +define N_DIM 2 # Dimensionality of plotting space +define N_SIDES 4 # Number of sides to a window +define MAX_LABEL_POINTS 100 # The maximum number of possible label points +define N_EDGES 20 # Number of edges being examined from the window + +# Define the types of graphs possible. + +define GRAPHTYPES "|normal|polar|near_polar|" +define NORMAL 1 +define POLAR 2 +define NEAR_POLAR 3 + +# Define the graph sides. The ordering matches the calls to the GIO package. + +define GRAPHSIDES "|left|right|bottom|top|" +define LEFT 1 +define RIGHT 2 +define BOTTOM 3 +define TOP 4 + +# Define which index refers to the X-axis and which refers to the Y-axis. + +define X_DIM 1 +define Y_DIM 2 +define AXIS1 1 +define AXIS2 2 + +# Define which axis is longitude and which axis is latitude. + +define LONGITUDE 1 +define LATITUDE 2 + +# Define the available precisions for labelling + +define HOUR 1 +define DEGREE 1 +define MINUTE 2 +define SECOND 3 +define SUBSEC_LOW 4 +define SUBSEC_HIGH 5 + +# Define the possible MWCS transformation types. + +define RA_DEC_DICTIONARY "|tan|arc|sin|" +define LINEAR_DICTIONARY "|linear|" + +define NUMBER_OF_SUPPORTED_TYPES 2 +define RA_DEC 1 +define LINEAR 2 + +define AXIS 3B # transform all axes in any MWCS call + +# Some useful graphics definitions and defaults + +define NDC_WCS 0 # the base graphics WCS +define POLE_MARK_SHAPE 4 # the pole mark is a cross +define POLE_MARK_SIZE 3.0 # the half-size of the cross +define DISTANCE_TO_POLE 0.1 # % distance to pole for lines of longitude +define LINE_SIZE 1. # line width for lines and ticks +define MIN_ANGLE 10. # minimum angle for text rotation +define BOTTOM_LEFT .1 # default bottom left corner of viewport +define TOP_RIGHT .9 # default top right corner of viewport + +# Units conversion macros + +define RADTOST (240*RADTODEG($1)) # Radians to seconds of time +define RADTOSA (3600*RADTODEG($1)) # Radians to seconds of arc +define STTORAD (DEGTORAD(($1)/240)) # Seconds of time to radians +define SATORAD (DEGTORAD(($1)/3600)) # Seconds of arc to radians +define RADTOHRS (RADTODEG(($1)/15)) # Radians to hours +define HRSTORAD (DEGTORAD(15*($1))) # Hours to radians +define DEGTOST (240*($1)) # Degrees to seconds of time. +define STTODEG (($1)/240) # Seconds of time to degrees. +define DEGTOSA (3600*($1)) # Degrees to seconds of arc. +define SATODEG (($1)/3600) # Seconds of arc to degrees. +define HRSTODEG (($1)*15) # Hours to degrees. +define DEGTOHRS (($1)/15) # Degrees to hours. +define STPERDAY 86400 # Seconds per day + +# Other useful macros + +define INVERT ($1 < 45 || $1 > 315 || ( $1 > 135 && $1 < 225 )) + +# Define the latitudes of the north and south poles + +define NORTH_POLE_LATITUDE 90.0D0 +define SOUTH_POLE_LATITUDE -90.0D0 + +# Define sections of a circle + +define QUARTER_CIRCLE 90.0D0 +define HALF_CIRCLE 180.0D0 +define FULL_CIRCLE 360.0D0 diff --git a/pkg/utilities/nttools/stxtools/wcslab/wcslab.x b/pkg/utilities/nttools/stxtools/wcslab/wcslab.x new file mode 100644 index 00000000..2e6974c6 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/wcslab.x @@ -0,0 +1,935 @@ +include <gset.h> +include <imhdr.h> +include <math.h> +include <mwset.h> +include "wcslab.h" +include "wcs_desc.h" +include <ctype.h> + + +# WCSLAB -- Procedure to draw labels and grids in sky projection coordinates. +# +# Description +# Wcslab produces a labelling and grid based on the MWCS of a +# specified image. +# +# The only things necessary to run this routine are: +# 1) Open an image and pass the image descriptor in im. +# 2) Open the graphics device and set the desired viewport (with a +# gsview call). +# 3) Make sure that the wlpars pset is available. +# +# Upon return, the graphics system will be in the state that it had been +# left in and a "virtual viewport" will be returned in the arguments +# left, right, bottom, top. This viewport defines the region where labels +# and/or titles were written. If any graphics is performed within this +# region, chances are that something will be overwritten. If any other +# graphics remain outside this region, then what was produced by this +# subroutine will remain untouched. +# +# Bugs +# Can only handle sky projections for Right Ascension/Declination. This +# should be able to deal with any of the projections for this system, but +# has only been tested with the Tangent projection. + +procedure wcslab (mw, log_x1, log_x2, log_y1, log_y2, gp, title) + +pointer mw # I: the wcs descriptor +real log_x1, log_x2 # I/O: the viewport +real log_y1, log_y2 # I/O: the viewport +pointer gp # I: the graphics descriptor +char title[ARB] # I: the image title + +pointer wd +real junkx1, junkx2, junky1, junky2 +bool clgetb() +pointer wl_create() +errchk clgstr + +begin + # Allocate the descriptor. + wd = wl_create() + + # Set the title name. + call strcpy (title, WL_TITLE(wd), SZ_LINE) + + # Set the WCS descriptor. If the descriptor is NULL or if + # the use_wcs parameter is yes, retrieve the parameter + # specified wcs. + if (mw == NULL) + call wl_wcs_params (mw, log_x1, log_x2, log_y1, log_y2) + else if (clgetb ("usewcs")) + call wl_wcs_params (mw, junkx1, junkx2, junky1, junky2) + WL_MW(wd) = mw + + # Determine axis types. + call wl_get_system_type (WL_MW(wd), WL_SYSTEM_TYPE(wd), + WL_LOGICAL_CENTER(wd,1), WL_WORLD_CENTER(wd,1), WL_AXIS_FLIP(wd)) + if (IS_INDEFI(WL_SYSTEM_TYPE(wd))) + call error (0, "WCSLAB: Image WCS is unsupported\n") + + # Get the parameters. + call wl_gr_inparams (wd) + + # Copy the graphics descriptor. + WL_GP(wd) = gp + + # Set the plot window in pixels (the logical space of the WCS). + WL_SCREEN_BOUNDARY(wd,LEFT) = log_x1 + WL_SCREEN_BOUNDARY(wd,RIGHT) = log_x2 + WL_SCREEN_BOUNDARY(wd,BOTTOM) = log_y1 + WL_SCREEN_BOUNDARY(wd,TOP) = log_y2 + + # Plot and label the coordinate grid. + call wl_wcslab (wd) + + # Return the possibly modified graphics descriptor and viewport. + gp = WL_GP(wd) + call gsview (gp, WL_NEW_VIEW(wd,LEFT), WL_NEW_VIEW(wd,RIGHT), + WL_NEW_VIEW(wd,BOTTOM), WL_NEW_VIEW(wd,TOP)) + + # Save the current parameters. + if (WL_REMEMBER(wd) == YES) + call wl_gr_remparams (wd) + + # Release the memory. + call wl_destroy (wd) +end + + +# WL_CREATE -- Create a WCSLAB descriptor and initialize it. +# +# Description +# This routine allocates the memory for the WCSLAB descriptor and +# subarrays and initializes values. +# +# Returns +# the pointer to the WCSLAB descriptor. + +pointer procedure wl_create() + +int i,j +pointer wd + +begin + # Allocate the descriptor memory. + call malloc (wd, WL_LEN, TY_STRUCT) + + # Allocate the subarrays. + call malloc (WL_AXIS_TITLE_PTR(wd), SZ_LINE * N_DIM, TY_CHAR) + call malloc (WL_AXIS_TITLE_SIDE_PTR(wd), N_SIDES * N_DIM, TY_BOOL) + call malloc (WL_BEGIN_PTR(wd), N_DIM, TY_DOUBLE) + call malloc (WL_END_PTR(wd), N_DIM, TY_DOUBLE) + call malloc (WL_LABEL_ANGLE_PTR(wd), MAX_LABEL_POINTS, TY_DOUBLE) + call malloc (WL_LABEL_AXIS_PTR(wd), MAX_LABEL_POINTS, TY_INT) + call malloc (WL_LABEL_POSITION_PTR(wd), N_DIM * MAX_LABEL_POINTS, + TY_DOUBLE) + call malloc (WL_LABEL_SIDE_PTR(wd), N_DIM * N_SIDES, TY_BOOL) + call malloc (WL_LABEL_VALUE_PTR(wd), MAX_LABEL_POINTS, TY_DOUBLE) + call malloc (WL_LOGICAL_CENTER_PTR(wd), N_DIM, TY_DOUBLE) + call malloc (WL_MAJ_I_PTR(wd), N_DIM, TY_DOUBLE) + call malloc (WL_MIN_I_PTR(wd), N_DIM, TY_INT) + call malloc (WL_NV_PTR(wd), N_SIDES, TY_REAL) + call malloc (WL_SCREEN_BOUNDARY_PTR(wd), N_SIDES, TY_DOUBLE) + call malloc (WL_TITLE_PTR(wd), SZ_LINE, TY_CHAR) + call malloc (WL_WORLD_CENTER_PTR(wd), N_DIM, TY_DOUBLE) + + # Initialize the simple values (should be the same as the parameter + # file). + WL_POLAR_LABEL_POSITION(wd) = INDEF + WL_AXIS_TITLE_SIZE(wd) = 1.5 + WL_LABEL_SIZE(wd) = 1.0 + WL_MAJ_TICK_SIZE(wd) = .03 + WL_MIN_TICK_SIZE(wd) = .01 + WL_TITLE_SIZE(wd) = 2.0 + WL_GRAPH_TYPE(wd) = INDEFI + WL_MAJ_LINE_TYPE(wd) = GL_SOLID + WL_MIN_LINE_TYPE(wd) = GL_DOTTED + WL_TITLE_SIDE(wd) = TOP + WL_ALWAYS_FULL_LABEL(wd) = NO + WL_LABEL_ROTATE(wd) = YES + WL_LABON(wd) = YES + WL_LABOUT(wd) = YES + WL_MAJ_GRIDON(wd) = YES + WL_MIN_GRIDON(wd) = NO + WL_REMEMBER(wd) = NO + WL_TICK_IN(wd) = YES + + # Initialize any strings. + call strcpy ("imtitle", WL_TITLE(wd), SZ_LINE) + + # Initialize the axis dependent values. + do i = 1, N_DIM { + WL_AXIS_TITLE(wd,i) = EOS + WL_AXIS_TITLE_SIDE(wd,i) = INDEFI + WL_BEGIN(wd,i) = INDEFD + WL_END(wd,i) = INDEFD + WL_MAJOR_INTERVAL(wd,i) = INDEFD + WL_MINOR_INTERVAL(wd,i) = 5 + do j = 1, N_SIDES + WL_LABEL_SIDE(wd,j,i) = false + } + + # Return the descriptor. + return (wd) +end + + +# WL_WCS_PARAMS -- Read the WCS descriptor from the parameters. +# +# Description +# This procedure returns the WCS descriptor created from task parameters +# and the logical space that will be graphed. +# +# Bugs +# This only deals with two axes. + +procedure wl_wcs_params (mw, log_x1, log_x2, log_y1, log_y2) + +pointer mw # O: The MWCS descriptor. +real log_x1, log_x2, # O: The extent of the logical space to graph. +real log_y1, log_y2 + +real cd[2,2], r[2], w[2] +pointer sp, input, pp +pointer clopset(), mw_open() +real clgpsetr() + +begin + call smark (sp) + call salloc (input, SZ_LINE, TY_CHAR) + + # Open the pset. + pp = clopset ("wcspars") + + # Create an MWCS descriptor. + mw = mw_open (NULL, 2) + + # Get the types. + call clgpset (pp, "ctype1", Memc[input], SZ_LINE) + call wl_decode_ctype (mw, Memc[input], 1) + call clgpset (pp, "ctype2", Memc[input], SZ_LINE) + call wl_decode_ctype (mw, Memc[input], 2) + + # Get the reference coordinates. + r[1] = clgpsetr (pp, "crpix1") + r[2] = clgpsetr (pp, "crpix2") + w[1] = clgpsetr (pp, "crval1") + w[2] = clgpsetr (pp, "crval2") + + # Get the CD matrix. + cd[1,1] = clgpsetr (pp, "cd1_1") + cd[1,2] = clgpsetr (pp, "cd1_2") + cd[2,1] = clgpsetr (pp, "cd2_1") + cd[2,2] = clgpsetr (pp, "cd2_2") + + # Set the Wterm. + call mw_swtermr (mw, r, w, cd, 2) + + # Get the extent of the logical space. + log_x1 = clgpsetr (pp, "log_x1") + log_x2 = clgpsetr (pp, "log_x2") + log_y1 = clgpsetr (pp, "log_y1") + log_y2 = clgpsetr (pp, "log_y2") + + # Close the pset. + call clcpset (pp) + + call sfree (sp) +end + + +# WL_DECODE_CTYPE -- Decode the ctype string into axis type and system type. +# +# Description +# The CTYPE is what is found in FITS keywords CTYPEn. The value may +# contain two pieces of information, always the system type and possibly +# an individual axis type. For systems such as plain old linear systems +# just a system type is defined. However, for celestial systems, both +# types are defined in the form "axistype-systemtype". There may be +# any number of '-' in between the values. + +procedure wl_decode_ctype (mw, input, axno) + +pointer mw # I: the MWCS descriptor +char input[ARB] # I: the string input +int axno # I: the axis being worked on + +int i, input_len +int strncmp(), strldx(), strlen() +string empty "" + +begin + + input_len = strlen (input) + + # Fix some characters. + do i = 1, input_len { + if (input[i] == ' ' || input[i] == '\'') + break + else if (IS_UPPER(input[i])) + input[i] = TO_LOWER(input[i]) + else if (input[i] == '_') + input[i] = '-' + } + + # Determine the type of function on this axis. + if (strncmp (input, "linear", 6) == 0) { + call mw_swtype (mw, 1, 2, "linear", empty) + + } else if (strncmp (input, "ra--", 4) == 0) { + i = strldx ("-", input) + 1 + call mw_swtype (mw, 1, 2, input[i], empty) + call mw_swattrs (mw, axno, "axtype", "ra") + + } else if (strncmp (input, "dec-", 4) == 0) { + i = strldx ("-", input) + 1 + call mw_swtype (mw, 1, 2, input[i], empty) + call mw_swattrs (mw, axno, "axtype", "dec") + + } else { + # Since we have to be able to read any FITS header, we have + # no control over the value of CTYPEi. If the value is + # something we don't know about, assume a LINEAR axis, using + # the given value of CTYPEi as the default axis label. + call mw_swtype (mw, 1, 2, "linear", empty) + call mw_swattrs (mw, axno, "label", input) + } + +end + + +# WL_GET_SYSTEM_TYPE -- Determine type of transformation the MWCS represents. +# +# Note +# For some systems, the axis mapping reverses the order to make +# the rest of the code tractable. The only problem is that when graphing, +# the graph routines need to "fix" this reversal. Also note that this +# occurs only for systems that have distinct axis types, such as RA and +# DEC. +# +# Bugs +# A potential problem: For a WCS that has more axes than necessary +# for the sky projections, those axis are set such that during +# transformations, the first index position is used. For the one +# example I have seen, the "third" axis is time and this interpretation +# works. But, I am sure something will fall apart because of this. + +procedure wl_get_system_type (mw, system_type, logical_center, world_center, + flip) + +pointer mw # I: the MWCS descriptor. +int system_type # O: the transformation type: + # RA_DEC -> tan, sin, or arc projection + # in right ascension and + # declination + # LINEAR -> any regular linear system + # INDEFI -> could not be determined +double logical_center[N_DIM] # O: the center point in the logical system. +double world_center[N_DIM] # O: the center point in the world system. +int flip # O: true if the order of the axes have been + # changed by axis mappins + +double tmp_logical[MAX_DIM], tmp_world[MAX_DIM] +int wcs_dim, axis, index_sys1, index_sys2, found_axis +int axno[MAX_DIM], axval[MAX_DIM], found_axis_list[N_DIM] +pointer sp, axtype, cd, cur_type +int mw_stati(), strncmp(), strdic() +errchk mw_gwattrs + +begin + # Get some memory. + call smark (sp) + call salloc (axtype, SZ_LINE, TY_CHAR) + call salloc (cur_type, SZ_LINE, TY_CHAR) + call salloc (cd, MAX_DIM, TY_DOUBLE) + + # Get the dimensionality of the WCS. + call mw_seti (mw, MW_USEAXMAP, NO) + wcs_dim = mw_stati (mw, MW_NDIM) + + # Initialize the two dimensions. + index_sys1 = INDEFI + index_sys2 = INDEFI + + # Look through the possible supported axis types. When a type has + # exactly N_DIM axes defined, that will be the one used. + + for (system_type = 1; system_type <= NUMBER_OF_SUPPORTED_TYPES; + system_type = system_type + 1) { + + # Determine the string that should be looked for. + switch (system_type) { + case RA_DEC: + call strcpy (RA_DEC_DICTIONARY, Memc[cur_type], SZ_LINE) + case LINEAR: + call strcpy (LINEAR_DICTIONARY, Memc[cur_type], SZ_LINE) + } + + # Initialize the number of found axis. + found_axis = 0 + + # Examine each axis to determine whether the current axis type is + # the one to use. + for (axis = 1; axis <= wcs_dim; axis = axis + 1) { + + # If the current physical axis is not mapped, ignore it. + # This statement is causing a problem in 2.10.3, not sure + # why but am removing it for now. + #if (axno[axis] == 0) + #next + + ifnoerr (call mw_gwattrs( mw, axis, "wtype", Memc[axtype], + SZ_LINE)) { + call strlwr (Memc[axtype]) + + # If this axis type matches the one being looked for, add + # it to the axis list. If there are too many axis of the + # current type found, don't add to the found axis list. + + if (strdic (Memc[axtype], Memc[axtype], SZ_LINE, + Memc[cur_type]) > 0) { + found_axis = found_axis + 1 + if (found_axis <= N_DIM) + found_axis_list[found_axis] = axis + } + } + } + + # Check to see whether we have the right number axes. + if (found_axis == N_DIM) + break + + } + + # If any axes were found, then further check axis types. + # Depending on the axis type, there may be need to distinguish + # between the two possible axis further. + + if (found_axis == N_DIM) + switch (system_type) { + case RA_DEC: + for (axis = 1; axis <= N_DIM; axis = axis + 1) + ifnoerr (call mw_gwattrs (mw, found_axis_list[axis], + "axtype", Memc[axtype], SZ_LINE)) { + call strlwr( Memc[axtype] ) + if (strncmp (Memc[axtype], "ra", 2) == 0) + index_sys1 = found_axis_list[axis] + else if (strncmp (Memc[axtype], "dec", 3) == 0) + index_sys2 = found_axis_list[axis] + } + + # The "default" seems to be the LINEAR case for MWCS. + # Since no other information is provided, this is all we know. + default: + index_sys1 = found_axis_list[1] + index_sys2 = found_axis_list[2] + } + + # If either axis is unknown, something is wrong. If the WCS has two + # axes defined, then make some grand assumptions. If not, then there + # is nothing more to be done. + + if (IS_INDEFI (index_sys1) || IS_INDEFI (index_sys2)) { + if (wcs_dim >= N_DIM) { + index_sys1 = 1 + index_sys2 = 2 + } else + call error (0, "Wcslab: Fewer than two defined axes") + } + + # Zero the axis values and set any "unknown" axis to always use the + # "first" position in that axis direction. This will more than likely + # be a problem, but no general solution comes to mind this second. + + call amovki (0, axno, wcs_dim) + call amovki (0, axval, wcs_dim) + + # Setup so that the desired axes are set as the X and Y axis. + axno[index_sys1] = X_DIM + axno[index_sys2] = Y_DIM + call mw_saxmap (mw, axno, axval, wcs_dim) + + # Recover the center points of the Logical and World systems. + call mw_gwtermd (mw, tmp_logical, tmp_world, Memd[cd], wcs_dim) + + logical_center[X_DIM] = tmp_logical[index_sys1] + logical_center[Y_DIM] = tmp_logical[index_sys2] + world_center[X_DIM] = tmp_world[index_sys1] + world_center[Y_DIM] = tmp_world[index_sys2] + + # Check for reversal of axes + if (index_sys1 > index_sys2) + flip = YES + else + flip = NO + + # Release the memory. + call sfree (sp) +end + + +# WL_GR_INPARAMS -- Read in the graphics parameters for wcslab. +# +# Description +# Read all the parameters in and make some decisions about what +# will be done. + +procedure wl_gr_inparams (wd) + +pointer wd # I: the WCSLAB descriptor + +pointer sp, aline, pp +bool clgpsetb(), streq() +double wl_string_to_internal() +int btoi(), strdic(), wl_line_type(), clgpseti() +pointer clopset() +real clgpsetr() + +begin + # Get some memory. + call smark (sp) + call salloc (aline, SZ_LINE, TY_CHAR) + + # Open the pset. + pp = clopset ("wlpars") + + # Get the title if other than the default. + call clgpset (pp, "title", Memc[aline], SZ_LINE) + if (! streq (Memc[aline], "imtitle")) + call strcpy (Memc[aline], WL_TITLE(wd), SZ_LINE) + + # Get the axis titles. + call clgpset (pp, "axis1_title", WL_AXIS_TITLE(wd,AXIS1), SZ_LINE) + call clgpset (pp, "axis2_title", WL_AXIS_TITLE(wd,AXIS2), SZ_LINE) + + # Get the parameters. + WL_ALWAYS_FULL_LABEL(wd) = btoi (clgpsetb (pp,"full_label")) + WL_AXIS_TITLE_SIZE(wd) = clgpsetr (pp, "axis_title_size") + WL_LABEL_ROTATE(wd) = btoi (clgpsetb (pp, "rotate")) + WL_LABEL_SIZE(wd) = clgpsetr (pp, "label_size") + WL_LABON(wd) = btoi (clgpsetb (pp, "dolabel")) + WL_LABOUT(wd) = btoi (clgpsetb (pp, "labout")) + WL_MAJ_GRIDON(wd) = btoi (clgpsetb (pp, "major_grid")) + WL_MAJ_TICK_SIZE(wd) = clgpsetr (pp, "major_tick") + WL_MIN_GRIDON(wd) = btoi (clgpsetb (pp, "minor_grid")) + WL_MINOR_INTERVAL(wd,AXIS1) = clgpseti (pp, "axis1_minor") + WL_MINOR_INTERVAL(wd,AXIS2) = clgpseti (pp, "axis2_minor") + WL_MIN_TICK_SIZE(wd) = clgpsetr (pp, "minor_tick") + WL_REMEMBER(wd) = btoi (clgpsetb (pp, "remember")) + WL_TICK_IN(wd) = btoi (clgpsetb (pp, "tick_in")) + WL_TITLE_SIZE(wd) = clgpsetr (pp, "title_size") + + # Set what type of graph will be plotted. + call clgpset (pp, "graph_type", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + WL_GRAPH_TYPE(wd) = strdic (Memc[aline], Memc[aline], SZ_LINE, + GRAPHTYPES) + if (WL_GRAPH_TYPE(wd) <= 0) + WL_GRAPH_TYPE(wd) = INDEFI + + # Get which sides labels will appear on. + call clgpset (pp, "axis1_side", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + call wl_label_side (Memc[aline], WL_LABEL_SIDE(wd,1,AXIS1)) + + call clgpset (pp, "axis2_side", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + call wl_label_side (Memc[aline], WL_LABEL_SIDE(wd,1,AXIS2)) + + # Get the polar justification direction. + call clgpset (pp, "justify", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + WL_POLAR_LABEL_DIRECTION(wd) = strdic (Memc[aline], Memc[aline], + SZ_LINE, GRAPHSIDES) + if (WL_POLAR_LABEL_DIRECTION(wd) <= 0) + WL_POLAR_LABEL_DIRECTION(wd) = INDEFI + + # Decode the graphing parameters. + call clgpset (pp, "axis1_int", Memc[aline], SZ_LINE) + WL_MAJOR_INTERVAL(wd,AXIS1) = wl_string_to_internal (Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS1) + call clgpset (pp, "axis1_beg", Memc[aline], SZ_LINE) + WL_BEGIN(wd,AXIS1) = wl_string_to_internal (Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS1) + call clgpset (pp, "axis1_end", Memc[aline], SZ_LINE) + WL_END(wd,AXIS1) = wl_string_to_internal (Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS1) + + call clgpset (pp, "axis2_int", Memc[aline], SZ_LINE) + WL_MAJOR_INTERVAL(wd,AXIS2) = wl_string_to_internal (Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS2) + call clgpset (pp, "axis2_beg", Memc[aline], SZ_LINE) + WL_BEGIN(wd,AXIS2) = wl_string_to_internal(Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS2 ) + call clgpset (pp, "axis2_end", Memc[aline], SZ_LINE) + WL_END(wd,AXIS2) = wl_string_to_internal (Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS2) + + # Get the polar label position. + call clgpset (pp, "axis2_dir", Memc[aline], SZ_LINE) + WL_POLAR_LABEL_POSITION(wd) = wl_string_to_internal( Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS1) + + # Get the axis titles. + call clgpset (pp, "axis1_title_side", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + WL_AXIS_TITLE_SIDE(wd,AXIS1) = strdic (Memc[aline], Memc[aline], + SZ_LINE, GRAPHSIDES) + if (WL_AXIS_TITLE_SIDE(wd,AXIS1) <= 0) + WL_AXIS_TITLE_SIDE(wd,AXIS1) = INDEFI + + call clgpset (pp, "axis2_title_side", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + WL_AXIS_TITLE_SIDE(wd,AXIS2) = strdic (Memc[aline], Memc[aline], + SZ_LINE, GRAPHSIDES) + if (WL_AXIS_TITLE_SIDE(wd,AXIS2) <= 0) + WL_AXIS_TITLE_SIDE(wd,AXIS2) = INDEFI + + # Decode the grid line types. + call clgpset (pp, "major_line", Memc[aline], SZ_LINE) + WL_MAJ_LINE_TYPE(wd) = wl_line_type (Memc[aline]) + call clgpset (pp, "minor_line", Memc[aline], SZ_LINE) + WL_MIN_LINE_TYPE(wd) = wl_line_type (Memc[aline]) + + # Get the title side. + call clgpset (pp, "title_side", Memc[aline], SZ_LINE) + call strlwr (Memc[ aline]) + WL_TITLE_SIDE(wd) = strdic (Memc[aline], Memc[aline], SZ_LINE, + GRAPHSIDES) + + # Close the pset. + call clcpset (pp) + + # Free memory. + call sfree (sp) +end + + +# WL_GR_REMPARAMS -- Write out the graphing parameters. + +procedure wl_gr_remparams (wd) + +pointer wd # I: the WCSLAB descriptor. + +pointer sp, output, pp +pointer clopset() + +begin + # Get some memory. + call smark (sp) + call salloc (output, SZ_LINE, TY_CHAR) + + # Open the pset. + pp = clopset ("wlpars") + + # Set the graph type. + switch (WL_GRAPH_TYPE(wd)) { + case NORMAL: + call clppset (pp, "graph_type", "normal") + case POLAR: + call clppset (pp, "graph_type", "polar") + case NEAR_POLAR: + call clppset (pp, "graph_type", "near_polar") + default: + call clppset (pp, "graph_type", "default") + } + + # Write back the labelling parameters. + call wl_internal_to_string (WL_MAJOR_INTERVAL(wd,AXIS1), + WL_SYSTEM_TYPE(wd), AXIS1, Memc[output]) + call clppset (pp, "axis1_int", Memc[output]) + call wl_internal_to_string (WL_BEGIN(wd,AXIS1), WL_SYSTEM_TYPE(wd), + AXIS1, Memc[output]) + call clppset (pp, "axis1_beg", Memc[output]) + call wl_internal_to_string (WL_END(WD,AXIS1), WL_SYSTEM_TYPE(wd), + AXIS1, Memc[output]) + call clppset (pp, "axis1_end", Memc[output]) + call wl_internal_to_string (WL_MAJOR_INTERVAL(wd,AXIS2), + WL_SYSTEM_TYPE(wd), AXIS2, Memc[output]) + call clppset (pp, "axis2_int", Memc[output]) + call wl_internal_to_string (WL_BEGIN(wd,AXIS2), WL_SYSTEM_TYPE(wd), + AXIS2, Memc[output]) + call clppset (pp, "axis2_beg", Memc[output]) + call wl_internal_to_string (WL_END(wd,AXIS2), WL_SYSTEM_TYPE(wd), + AXIS2, Memc[output]) + call clppset (pp, "axis2_end", Memc[output]) + call wl_internal_to_string (WL_POLAR_LABEL_POSITION(wd), + WL_SYSTEM_TYPE(wd), AXIS1, Memc[output]) + call clppset (pp, "axis2_dir", Memc[output]) + + # Write back labelling justification. + call wl_side_to_string (WL_POLAR_LABEL_DIRECTION(wd), Memc[output], + SZ_LINE) + call clppset (pp, "justify", Memc[output]) + + # Put the axis title sides out. + call wl_side_to_string (WL_AXIS_TITLE_SIDE(wd,AXIS1), Memc[output], + SZ_LINE) + call clppset (pp, "axis1_title_side", Memc[output]) + call wl_side_to_string (WL_AXIS_TITLE_SIDE(wd,AXIS2), Memc[output], + SZ_LINE ) + call clppset (pp, "axis2_title_side", Memc[output]) + + # Put the label sides out. + call wl_put_label_sides (WL_LABEL_SIDE(wd,1,AXIS1), Memc[output], + SZ_LINE ) + call clppset (pp, "axis1_side", Memc[output]) + call wl_put_label_sides (WL_LABEL_SIDE(wd,1,AXIS2), Memc[output], + SZ_LINE) + call clppset (pp, "axis2_side", Memc[output]) + + # Close the pset. + call clcpset (pp) + + # Free memory. + call sfree (sp) +end + + +# WL_DESTROY -- Deallocate the WCSLAB descriptor. + +procedure wl_destroy (wd) + +pointer wd # I: the WCSLAB descriptor to be destroyed + +begin + # Deallocate all the subarrays. + call mfree (WL_WORLD_CENTER_PTR(wd), TY_DOUBLE) + call mfree (WL_TITLE_PTR(wd), TY_CHAR) + call mfree (WL_SCREEN_BOUNDARY_PTR(wd), TY_DOUBLE) + call mfree (WL_NV_PTR(wd), TY_REAL) + call mfree (WL_MIN_I_PTR(wd), TY_INT) + call mfree (WL_MAJ_I_PTR(wd), TY_DOUBLE) + call mfree (WL_LOGICAL_CENTER_PTR(wd), TY_DOUBLE) + call mfree (WL_LABEL_VALUE_PTR(wd), TY_DOUBLE) + call mfree (WL_LABEL_SIDE_PTR(wd), TY_BOOL) + call mfree (WL_LABEL_POSITION_PTR(wd), TY_DOUBLE) + call mfree (WL_LABEL_AXIS_PTR(wd), TY_INT) + call mfree (WL_LABEL_ANGLE_PTR(wd), TY_DOUBLE) + call mfree (WL_END_PTR(wd), TY_DOUBLE) + call mfree (WL_BEGIN_PTR(wd), TY_DOUBLE) + call mfree (WL_AXIS_TITLE_SIDE_PTR(wd), TY_BOOL) + call mfree (WL_AXIS_TITLE_PTR(wd), TY_CHAR) + + # Now deallocate the structure. + call mfree (wd, TY_STRUCT) +end + + +# WL_LABEL_SIDE -- Decode string into set of booleans sides. + +procedure wl_label_side (input, flag) + +char input[ARB] # I: string listing the sides to be labeled +bool flag[N_SIDES] # O: the flags indicating which sides wll be labeled + +int i +int strmatch() + +begin + # Initialize all the flags to false. + do i = 1, N_SIDES + flag[i] = false + + # Now set each side that is in the list. + if (strmatch (input, "right") != 0) + flag[RIGHT] = true + if (strmatch (input, "left") != 0) + flag[LEFT] = true + if (strmatch (input, "top") != 0) + flag[TOP] = true + if (strmatch (input, "bottom") != 0) + flag[BOTTOM] = true +end + + +# WL_STRING_TO_INTERVAL -- Convert from a string to a number. +# +# Description +# Since (ideally) the wcslab task should be able to handle any sky +# map transformation, there are a number of potential units that can be +# transformed from. The specification of coordinates in these systems +# are also quite varied. Thus, for input purposes, coordinates are entered +# as strings. This routine decodes the strings to a common unit (degrees) +# based on the type of system being graphed. +# +# Function Returns +# This returns the single coordinate value converted to a base system +# (degrees). + +double procedure wl_string_to_internal (input, axis_type, which_axis) + +char input[ARB] # I; the string containing the numerical value +int axis_type # I: the type of wcs +int which_axis # I: the axis number + +double value +int strlen(), nscan() + +begin + # It is possible that the value was not defined. + if (strlen (input) <= 0) + value = INDEFD + + # Decode based on the system. + else + switch (axis_type) { + + # The RA and DEC systems. + case RA_DEC: + + # Since SPP FMTIO can handle the HH:MM:SS format, just let it + # read in the value. However, there is no way to distinquish + # H:M:S from D:M:S. If the axis being read is RA, assume that + # it was H:M:S. + + call sscan (input) + call gargd (value) + + # If the axis is Longitude == RA, then convert the hours to + # degrees. + if (nscan() < 1) { + value = INDEFD + } else { + if (which_axis == AXIS1) + value = HRSTODEG (value) + } + + # Default- unknown system, just read the string as a double + # precision and return it. + default: + call sscan (input) + call gargd (value) + if (nscan() < 1) + value = INDEFD + } + + return (value) +end + + +# WL_LINE_TYPE -- Decode a string into an IRAF GIO polyline type. + +int procedure wl_line_type (line_type_string) + +char line_type_string[ARB] # I: the string specifying the line type + # "solid" -> GL_SOLID + # "dotted" -> GL_DOTTED + # "dashed" -> GL_DASHED + # "dotdash" -> GL_DOTDASH +int type +bool streq() + +begin + if (streq (line_type_string, "solid")) + type = GL_SOLID + else if (streq (line_type_string, "dotted")) + type = GL_DOTTED + else if (streq( line_type_string, "dashed")) + type = GL_DASHED + else if (streq (line_type_string, "dotdash")) + type = GL_DOTDASH + else { + call eprintf ("Pattern unknown, using 'solid'.\n") + type = GL_SOLID + } + + return (type) +end + + +# WL_INTERNAL_TO_STRING - Convert internal representation to a string. + +procedure wl_internal_to_string (value, system_type, which_axis, output) + +double value # I: the value to convert +int system_type # I: the wcs type +int which_axis # I: the axis +char output[ARB] # O: the output string + +begin + # If the value is undefined, write an empty string. + if (IS_INDEFD (value)) + output[1] = EOS + + # Else, convert the value depending on the axis types. + else + switch (system_type) { + + # Handle the RA, DEC + case RA_DEC: + + # If this is Axis1 == Right Ascension, then convert to hours. + if (which_axis == AXIS1) + value = value / 15.0D0 + + call sprintf (output, SZ_LINE, "%.6h") + call pargd (value) + + # Else, just write a value. + default: + call sprintf (output, SZ_LINE, "%.7g") + call pargd (value) + } + +end + + +# WL_SIDE_TO_STRING -- Convert a side to its string representation. + +procedure wl_side_to_string (side, output, max_len) + +int side # I: the side to convert +char output[max_len] # O: the string representation of the side +int max_len # I: the maximum length of the output string + +begin + switch (side) { + case RIGHT: + call strcpy ("right", output, max_len) + case LEFT: + call strcpy ("left", output, max_len) + case TOP: + call strcpy ("top", output, max_len) + case BOTTOM: + call strcpy ("bottom", output, max_len) + default: + call strcpy ("default", output, max_len) + } +end + + +# WL_PUT_LABEL_SIDES -- Create a string containing the sides specified. + +procedure wl_put_label_sides (side_flags, output, max_len) + +bool side_flags[N_SIDES] # I: the boolean array of sides +char output[ARB] # O: the output comma separated list of sides +int max_len # I: maximum length of the output string + +int i +pointer sp, side +int strlen() + +begin + # Get memory. + call smark (sp) + call salloc (side, max_len, TY_CHAR) + + # Build the list. + output[1] = EOS + do i = 1, N_SIDES + if (side_flags[i]) { + if (strlen (output) != 0) + call strcat (",", output, max_len) + call wl_side_to_string (i, Memc[side], max_len) + call strcat (Memc[side], output, max_len) + } + + if (strlen (output) == 0) + call strcat ("default", output, max_len) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/wcslab/wlgrid.x b/pkg/utilities/nttools/stxtools/wcslab/wlgrid.x new file mode 100644 index 00000000..4f457af4 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/wlgrid.x @@ -0,0 +1,448 @@ +include <gset.h> +include <math.h> +include "wcslab.h" +include "wcs_desc.h" + + +# WL_GRID -- Put the grid lines/tick marks on the plot. +# +# Description +# Based on previously determined parameters., draw the grid lines and/or +# tick marks onto the graph. While in the process of doing this, create +# a list of possible label points for use by the label_grid routine. + +procedure wl_grid (wd) + +pointer wd # I: the WCSLAB descriptor + +double current, tmp_begin, tmp_end, tmp_minor_interval +int old_type, old_n_labels, min_counter +int gstati() + +begin + # Initialize the label counter. + WL_N_LABELS(wd) = 0 + + # Remember what line type is currently active. + old_type = gstati (WL_GP(wd), G_PLTYPE) + + # Determine integer range for axis 1. + tmp_minor_interval = WL_MAJOR_INTERVAL(wd,AXIS1) / + double (WL_MINOR_INTERVAL(wd,AXIS1)) + + # If near-polar, the lines should go all the way to the poles. + if (WL_GRAPH_TYPE(wd) == NEAR_POLAR) + if (abs (WL_BEGIN(wd,AXIS2)) < abs (WL_END(wd,AXIS2))) { + tmp_begin = WL_BEGIN(wd,AXIS2) + tmp_end = NORTH_POLE_LATITUDE + } else { + tmp_begin = SOUTH_POLE_LATITUDE + tmp_end = WL_END(wd,AXIS2) + } + else { + tmp_begin = WL_BEGIN(wd,AXIS2) + tmp_end = WL_END(wd,AXIS2) + } + + # Plot lines of constant value in axis 1. + current = WL_BEGIN(wd,AXIS1) + min_counter = 0 + repeat { + + if (mod (min_counter, WL_MINOR_INTERVAL(wd,AXIS1)) == 0) { + call gseti (WL_GP(wd), G_PLTYPE, WL_MAJ_LINE_TYPE(wd)) + call wl_graph_constant_axis1 (wd, current, tmp_begin, tmp_end, + WL_MAJ_GRIDON(wd), WL_LABON(wd), WL_MAJ_TICK_SIZE(wd)) + } else { + call gseti (WL_GP(wd), G_PLTYPE, WL_MIN_LINE_TYPE(wd)) + call wl_graph_constant_axis1 (wd, current, tmp_begin, tmp_end, + WL_MIN_GRIDON(wd), NO, WL_MIN_TICK_SIZE(wd)) + } + + min_counter = min_counter + 1 + current = WL_BEGIN(wd,AXIS1) + tmp_minor_interval * min_counter + + } until (real (current) > real (WL_END(wd,AXIS1))) + + # Determine the interval range for the second axis. + tmp_minor_interval = WL_MAJOR_INTERVAL(wd,AXIS2) / + double (WL_MINOR_INTERVAL(wd,AXIS2)) + + # Plot lines of constant value in axis 2. + if (WL_END(wd,AXIS2) < WL_BEGIN(wd,AXIS2)) { + current = WL_END(wd,AXIS2) + tmp_minor_interval = -tmp_minor_interval + tmp_end = WL_BEGIN(wd,AXIS2) + } else { + current = WL_BEGIN(wd,AXIS2) + tmp_end = WL_END(wd,AXIS2) + } + + min_counter = 0 + tmp_begin = current + repeat { + if (mod (min_counter, WL_MINOR_INTERVAL(wd,AXIS2)) == 0) { + + call gseti (WL_GP(wd), G_PLTYPE, WL_MAJ_LINE_TYPE(wd)) + old_n_labels = WL_N_LABELS(wd) + call wl_graph_constant_axis2 (wd, current, WL_BEGIN(wd,AXIS1), + WL_END(wd,AXIS1), WL_MAJ_GRIDON(wd), WL_LABON(wd), + WL_MAJ_TICK_SIZE(wd)) + + # If this is a polar or near_polar plot, the latitudes + # should be placed near the line, not where it crosses the + # window boundary. + + if (WL_GRAPH_TYPE(wd) == POLAR && + (WL_MAJ_GRIDON(wd) == YES) && (WL_LABON(wd) == YES)) { + WL_N_LABELS(wd) = old_n_labels + 1 + call wl_w2ld (WL_WLCT(wd), WL_AXIS_FLIP(wd), + WL_POLAR_LABEL_POSITION(wd), current, + WL_LABEL_POSITION(wd,WL_N_LABELS(wd),X_DIM), + WL_LABEL_POSITION(wd,WL_N_LABELS(wd),Y_DIM), 1) + WL_LABEL_VALUE(wd,WL_N_LABELS(wd)) = current + WL_LABEL_AXIS(wd,WL_N_LABELS(wd)) = AXIS2 + } + + } else { + call gseti (WL_GP(wd), G_PLTYPE, WL_MIN_LINE_TYPE(wd)) + call wl_graph_constant_axis2 (wd, current, WL_BEGIN(wd,AXIS1), + WL_END(wd,AXIS1), WL_MIN_GRIDON(wd), NO, + WL_MIN_TICK_SIZE(wd)) + } + + # Increment and continue + min_counter = min_counter + 1 + current = tmp_begin + tmp_minor_interval * min_counter + + } until (real (current) > real (tmp_end)) + + # Set the line type back to the way it was. + call gseti (WL_GP(wd), G_PLTYPE, old_type) +end + + +# WL_GRAPH_CONSTANT_AXIS1 - Graph lines of constant X-axis values. +# +# Description +# Because projections are rarely linear, the basic GIO interface to draw +# lines cannot be used. Instead, this routine handles the line drawing. +# Also, possible label points are found and added to a label list array. +# +# CLUDGE! Finding labels here is WRONG. Ideally, crossing points (where the +# line crosses a screen boundary) should be determined analytically. However, +# the MWCS interface lacks the required "cross-transformations". It can +# still be done, but requires a total bypassing of MWCS. Instead, this +# simplistic approach is used. + +procedure wl_graph_constant_axis1 (wd, x, ymin, ymax, gridon, label, tick_size) + +pointer wd # I: the WCSLAB descriptor +double x # I: X value to hold constant +double ymin, ymax # I: Y values to vary between +int gridon # I: true if gridding is on +int label # I: true if the points should be labelled +real tick_size # I: size of tick marks + +bool done +double lastx, lasty, lx, ly, y, yinc +real rlx, rly + +begin + # Determine the scale at which Y should be incremented. + yinc = (ymax - ymin) / WL_LINE_SEGMENTS(wd) + + # Now graph the line segments. + y = ymin + call wl_w2ld (WL_WLCT(wd), WL_AXIS_FLIP(wd), x, y, lastx, lasty, 1) + + rlx = lastx + rly = lasty + call gamove (WL_GP(wd), rlx, rly) + + repeat { + call wl_w2ld (WL_WLCT(wd), WL_AXIS_FLIP(wd), x, y, lx, ly, 1) + call wl_point_to_label (wd, lastx, lasty, lx, ly, AXIS1, x, gridon, + label, tick_size) + if (gridon == YES) { + rlx = lx + rly = ly + call gadraw (WL_GP(wd), rlx, rly) + } + if (yinc < 0.) + done = y < ymax + else + done = y > ymax + y = y + yinc + lastx = lx + lasty = ly + } until (done) +end + + +# WL_GRAPH_CONSTANT_AXIS2 -- Graph lines of constant Y-axis values. +# +# Description +# Because projections are rarely linear, the basic GIO interface to draw +# lines cannot be used. Instead, this routine handles the line drawing. +# Also, possible label points are found and added to an label list array. +# +# CLUDGE! Finding labels here is WRONG. Ideally, crossing points (where the +# line crosses a screen boundary) should be determined analytically. However, +# the MWCS interface lacks the required "cross-transformations". It can +# still be done, but requires a total bypassing of MWCS. Instead, this +# simplistic approach is used. + +procedure wl_graph_constant_axis2 (wd, y, xmin, xmax, gridon, label, tick_size) + +pointer wd # I: the WCSLAB descriptor +double y # I: Y value to hold constant +double xmin, xmax # I: X values to vary between +int gridon # I: true if gridding is on +int label # I: true if points should be labelled +real tick_size # I: tick mark size + +bool done +double lx, ly, lastx, lasty, x, xinc +real rlx, rly + +begin + # Determine the scale at which X should be incremented. + xinc = (xmax - xmin) / WL_LINE_SEGMENTS(wd) + + # Now graph the line segments. + x = xmin + call wl_w2ld (WL_WLCT(wd), WL_AXIS_FLIP(wd), x, y, lastx, lasty, 1) + + rlx = lastx + rly = lasty + call gamove (WL_GP(wd), rlx, rly) + + repeat { + call wl_w2ld (WL_WLCT(wd), WL_AXIS_FLIP(wd), x, y, lx, ly, 1) + call wl_point_to_label (wd, lastx, lasty, lx, ly, AXIS2, y, gridon, + label, tick_size) + if (gridon == YES) { + rlx = lx + rly = ly + call gadraw (WL_GP(wd), rlx, rly) + } + if (xinc < 0.) + done = x < xmax + else + done = x > xmax + lastx = lx + lasty = ly + x = x + xinc + } until (done) +end + + +# Define the inside and outside of the window. + +define OUT (($1<=WL_SCREEN_BOUNDARY(wd,LEFT))||($1>=WL_SCREEN_BOUNDARY(wd,RIGHT))||($2<=WL_SCREEN_BOUNDARY(wd,BOTTOM))||($2>=WL_SCREEN_BOUNDARY(wd,TOP))) + +define IN (($1>WL_SCREEN_BOUNDARY(wd,LEFT))&&($1<WL_SCREEN_BOUNDARY(wd,RIGHT))&&($2>WL_SCREEN_BOUNDARY(wd,BOTTOM))&&($2<WL_SCREEN_BOUNDARY(wd,TOP))) + + +# WL_POINT_TO_LABEL - Record a points position along a window boundary. +# +# Description +# Since the MWCS interface lacks "cross-transformations", i.e. If given +# RA and and X axis location, find DEC and Y axis, we need a different +# method of determining when lines of constant Axis 1/Axis 2 cross +# the window boundary. Since each line is drawn by small increments, each +# increment is watched to see if a window boundary has been crossed. This +# is what this routine does: Confirms that a boundary has been crossed, +# records this position and label value. Tick marks are also drawn here +# because all the necessary information is known at this point. +# +# NOTE: THIS WAY IS A CLUDGE ! A more formal method of finding +# cross-transformations is needed- most likely an iterative method. This +# way was just "convenient at the time". + +procedure wl_point_to_label (wd, x1, y1, x2, y2, axis, axis_value, gridon, + label, tick_size) + +pointer wd # I: the WCSLAB descriptor +double x1, y1, x2, y2 # I: the two possible points to label +int axis # I: which axis are we dealing with ? +double axis_value # I: the value of the axis at this point +int gridon # I: true if gridding is on +int label # I: true if this point should have a label +real tick_size # I: size of the tick mark + +double nx, ny, tick_x, tick_y +double wl_vector_angle() + +begin + # Determine whether the two points straddle a window boundary. If they + # do, then this is the point to label. + if (OUT (x1, y1) && IN (x2, y2)) { + + call wl_axis_on_line (x1, y1, x2, y2, WL_SCREEN_BOUNDARY(wd,1), + nx, ny) + + if (gridon == NO) { + call wl_mark_tick (WL_GP(wd), WL_NDC_WCS(wd), tick_size, + WL_TICK_IN(wd), x1, y1, x2, y2, nx, ny, tick_x, tick_y) + if (WL_TICK_IN(wd) != WL_LABOUT(wd)) { + nx = tick_x + ny = tick_y + } + } + + if ((label == YES) && WL_N_LABELS(wd) < MAX_LABEL_POINTS) { + WL_N_LABELS(wd) = WL_N_LABELS(wd) + 1 + WL_LABEL_POSITION(wd,WL_N_LABELS(wd),AXIS1) = nx + WL_LABEL_POSITION(wd,WL_N_LABELS(wd),AXIS2) = ny + WL_LABEL_VALUE(wd,WL_N_LABELS(wd)) = axis_value + WL_LABEL_AXIS(wd,WL_N_LABELS(wd)) = axis + WL_LABEL_ANGLE(wd,WL_N_LABELS(wd)) = + wl_vector_angle (WL_GP(wd), x1, y1, x2, y2) + } + } + + if (IN (x1, y1) && OUT (x2, y2)) { + + call wl_axis_on_line (x2, y2, x1, y1, WL_SCREEN_BOUNDARY(wd,1), + nx, ny) + + if (gridon == NO) { + call wl_mark_tick (WL_GP(wd), WL_NDC_WCS(wd), tick_size, + WL_TICK_IN(wd), x2, y2, x1, y1, nx, ny, tick_x, tick_y) + if (WL_TICK_IN(wd) != WL_LABOUT(wd)) { + nx = tick_x + ny = tick_y + } + } + + if ((label == YES) && WL_N_LABELS(wd) < MAX_LABEL_POINTS) { + WL_N_LABELS(wd) = WL_N_LABELS(wd) + 1 + WL_LABEL_POSITION(wd,WL_N_LABELS(wd),AXIS1) = nx + WL_LABEL_POSITION(wd,WL_N_LABELS(wd),AXIS2) = ny + WL_LABEL_VALUE(wd,WL_N_LABELS(wd)) = axis_value + WL_LABEL_AXIS(wd,WL_N_LABELS(wd)) = axis + WL_LABEL_ANGLE(wd,WL_N_LABELS(wd)) = + wl_vector_angle (WL_GP(wd), x1, y1, x2, y2) + } + } + +end + + +# WL_MARK_TICK - Draw the tick mark at the point. +# +# Description +# Draw a tick mark rooted at (sx,sy), whose direction is defined by +# the vector (x0,y0) to (x1,y1). The other end of the tick mark is +# returned in (tick_x,tick_y). + +procedure wl_mark_tick (gp, wcs, tick_size, in, x0, y0, x1, y1, sx, sy, + tick_x, tick_y) + +pointer gp # I: the graphics pointer +int wcs # I: the WCS to use to draw the tick marks +real tick_size # I: size of the tick mark +int in # I: true if ticks should be into the graph +double x0, y0, x1, y1 # I: the points defining the tick direction +double sx, sy # I: the root point of the tick mark +double tick_x, tick_y # O: the end point of the tick mark + +int old_line, old_wcs +real dx, dy, t, ndc_x0, ndc_y0, ndc_x1, ndc_y1, ndc_x2, ndc_y2 +real ndc_sx, ndc_sy +int gstati() +real wl_distancer() + +begin + # Change graphics coordinates to NDC. + old_wcs = gstati (gp, G_WCS) + old_line = gstati (gp, G_PLTYPE) + call gseti (gp, G_WCS, wcs) + call gseti (gp, G_PLTYPE, GL_SOLID) + + # Convert the points to NDC coordinates. + ndc_x2 = real (sx) + ndc_y2 = real (sy) + call gctran (gp, ndc_x2, ndc_y2, ndc_sx, ndc_sy, old_wcs, wcs) + ndc_x2 = real (x0) + ndc_y2 = real (y0) + call gctran (gp, ndc_x2, ndc_y2, ndc_x0, ndc_y0, old_wcs, wcs) + ndc_x2 = real (x1) + ndc_y2 = real (y1) + call gctran (gp, ndc_x2, ndc_y2, ndc_x1, ndc_y1, old_wcs, wcs) + + # Determine the parameterized line parameters. + dx = ndc_x1 - ndc_x0 + dy = ndc_y1 - ndc_y0 + + # Determine how large in "time" the tick mark is. + t = tick_size / wl_distancer (ndc_x0, ndc_y0, ndc_x1, ndc_y1) + + # If tick marks are to point out of the graph, reverse the sign of t. + # Also need to turn clipping off for the ticks appear. + if (in == NO) { + t = -t + call gseti (gp, G_CLIP, NO) + } + + # Determine the end point of the tick mark. + ndc_x2 = t * dx + ndc_sx + ndc_y2 = t * dy + ndc_sy + + # Now draw the tick mark. + call gamove (gp, ndc_sx, ndc_sy) + call gadraw (gp, ndc_x2, ndc_y2) + + # Restore clipping if necessary. + if (in == NO) + call gseti (gp, G_CLIP, YES) + + # Restore previous settings. + call gseti (gp, G_WCS, old_wcs) + call gseti (gp, G_PLTYPE, old_line) + + # Transform the end of the tick mark. + call gctran (gp, ndc_x2, ndc_y2, dx, dy, wcs, old_wcs) + tick_x = double (dx) + tick_y = double (dy) +end + + +# WL_VECTOR_ANGLE -- Return the angle represented by the given vector. +# +# Returns +# The angle of the given vector. + +double procedure wl_vector_angle (gp, x1, y1, x2, y2) + +pointer gp # I: the graphics descriptor +double x1, y1, x2, y2 # I: the end points of the vector + +double dangle +real angle, delx, dely, ndc_x1, ndc_x2, ndc_y1, ndc_y2 +bool fp_equalr() +int gstati() + +begin + # Translate the input points to NDC coordinates. + ndc_x1 = real (x1) + ndc_x2 = real (x2) + ndc_y1 = real (y1) + ndc_y2 = real (y2) + call gctran (gp, ndc_x1, ndc_y1, ndc_x1, ndc_y1, gstati (gp, G_WCS), + NDC_WCS) + call gctran (gp, ndc_x2, ndc_y2, ndc_x2, ndc_y2, gstati (gp, G_WCS), + NDC_WCS) + + dely = ndc_y2 - ndc_y1 + delx = ndc_x2 - ndc_x1 + if (fp_equalr (delx, 0.) && fp_equalr (dely, 0.)) + angle = 0.0 + else + angle = RADTODEG (atan2 (dely, delx)) + dangle = angle + + return (dangle) +end diff --git a/pkg/utilities/nttools/stxtools/wcslab/wllabel.x b/pkg/utilities/nttools/stxtools/wcslab/wllabel.x new file mode 100644 index 00000000..4578f89c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/wllabel.x @@ -0,0 +1,1100 @@ +include <gset.h> +include <math.h> +include "psiescape.h" +include "wcslab.h" +include "wcs_desc.h" + + +# Define the offset array. +define OFFSET Memr[$1+$2-1] + +# Define the postscript kernel +define PSIKERN "psikern" + +# WL_LABEL -- Place the labels on the grids. +# +# Description +# Format and write the labels for the grid/tick marks. Much of this +# is wading through conditions to decide whether a label should be +# written or not. + +procedure wl_label (wd) + +pointer wd # I: the WCSLAB descriptor + +bool no_side_axis1, no_side_axis2, streq() +int i, axis1_side, axis2_side +short flag +pointer kernel, sp, offset_ptr +real offset + +begin + # Get some memory. + call smark (sp) + call salloc (offset_ptr, N_SIDES, TY_REAL) + do i = 1, N_SIDES + OFFSET(offset_ptr,i) = 0. + call salloc (kernel, SZ_LINE, TY_CHAR ) + + # Decide whether any sides were specified for either axis. + no_side_axis1 = true + no_side_axis2 = true + do i = 1, N_SIDES { + if (WL_LABEL_SIDE(wd,i,AXIS1)) + no_side_axis1 = false + if (WL_LABEL_SIDE(wd,i,AXIS2)) + no_side_axis2 = false + } + + # If polar, then label the axis 2's next to their circles on the + # graph and allow the Axis 1s to be labeled on all sides of the graph. + + if (WL_GRAPH_TYPE(wd) == POLAR) { + + call wl_polar_label (wd) + + if (no_side_axis1) { + do i = 1, N_SIDES { + WL_LABEL_SIDE(wd,i,AXIS1) = true + } + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(WD,AXIS1))) + WL_AXIS_TITLE_SIDE(WD,AXIS1) = BOTTOM + } + + # If we are near-polar, label the Axis 2 as if polar, and label + # Axis1 on all sides except the side closest to the pole. + + } else if (WL_GRAPH_TYPE(wd) == NEAR_POLAR) { + + if (no_side_axis1) { + WL_LABEL_SIDE(wd,WL_BAD_LABEL_SIDE(wd),AXIS1) = true + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(wd,AXIS1))) + WL_AXIS_TITLE_SIDE(wd,AXIS1) = WL_BAD_LABEL_SIDE(wd) + } + + if (no_side_axis2) { + WL_LABEL_SIDE(wd,WL_POLAR_LABEL_DIRECTION(wd),AXIS2) = true + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(wd,AXIS2))) + WL_AXIS_TITLE_SIDE(wd,AXIS2) = WL_POLAR_LABEL_DIRECTION(wd) + } + + # Final case- adjacent sides should be labelled. + + } else { + + # Determine the best sides for labelling. + if (INVERT (WL_ROTA(wd))) { + axis1_side = LEFT + axis2_side = BOTTOM + } else { + axis1_side = BOTTOM + axis2_side = LEFT + } + + # If no sides were specified, use the calculated ones above. + if (no_side_axis1) + WL_LABEL_SIDE(wd,axis1_side,AXIS1) = true + if (no_side_axis2) + WL_LABEL_SIDE(wd,axis2_side,AXIS2) = true + } + + # Check to see if this is a psikern printer. If so, set text + # so that it is mono-spaced. The superscripting algorithm + # doesn't work too well in a proportional-spaced system. + call ggets (WL_GP(wd), "tn", Memc[kernel], SZ_LINE ) + if (streq (Memc[kernel], PSIKERN)) { + flag = NO + call gescape (WL_GP(wd), PS_VARIABLE_SPACE, flag, + PS_VARIABLE_SPACE_SIZE) + } + + # Now draw the labels for axis 1. + do i = 1, N_SIDES { + + if (WL_LABEL_SIDE(wd,i,AXIS1)) { + call wl_lab_edges (wd, AXIS1, i, offset) + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(WD,AXIS1))) + WL_AXIS_TITLE_SIDE(WD,AXIS1) = i + } else + offset = 0. + + # Modify the bounding box for the new viewport. + if (abs (offset) > abs (OFFSET(offset_ptr,i))) + OFFSET(offset_ptr,i) = offset + } + + # Draw the labels for axis 2. + if (WL_GRAPH_TYPE(wd) != POLAR) + do i = 1, N_SIDES { + + if (WL_LABEL_SIDE(wd,i,AXIS2)) { + call wl_lab_edges (wd, AXIS2, i, offset) + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(wd,AXIS2))) + WL_AXIS_TITLE_SIDE(wd,AXIS2) = i + } else + offset = 0. + + # Modify the bounding box for the new viewport. + if (abs (offset) > abs (OFFSET(offset_ptr,i))) + OFFSET(offset_ptr,i) = offset + } + + # Reset to variable spacing. + if (streq (Memc[kernel], PSIKERN)) { + flag = YES + call gescape (WL_GP(wd), PS_VARIABLE_SPACE, flag, + PS_VARIABLE_SPACE_SIZE) + } + + # Set the bounding box. + do i = 1, N_SIDES + WL_NEW_VIEW(wd,i) = WL_NEW_VIEW(wd,i) + OFFSET(offset_ptr,i) + + # Now write the graph title. + call wl_title (WL_GP(wd), WL_AXIS_TITLE(wd,AXIS1), + WL_AXIS_TITLE_SIDE(wd,AXIS1), WL_AXIS_TITLE_SIZE(wd), + WL_NEW_VIEW(wd,1)) + if (WL_GRAPH_TYPE(wd) != POLAR) + call wl_title (WL_GP(wd), WL_AXIS_TITLE(wd,AXIS2), + WL_AXIS_TITLE_SIDE(wd,AXIS2), WL_AXIS_TITLE_SIZE(WD), + WL_NEW_VIEW(wd,1)) + if (! IS_INDEFI (WL_TITLE_SIDE(wd))) + call wl_title (WL_GP(wd), WL_TITLE(wd), WL_TITLE_SIDE(wd), + WL_TITLE_SIZE(wd), WL_NEW_VIEW(wd,1)) + + # Release memory. + call sfree (sp) +end + + +# Define what is in the screen. + +define IN (($1>WL_SCREEN_BOUNDARY(wd,LEFT))&&($1<WL_SCREEN_BOUNDARY(wd,RIGHT))&&($2>WL_SCREEN_BOUNDARY(wd,BOTTOM))&&($2<WL_SCREEN_BOUNDARY(wd,TOP))) + +# WL_POLAR_LABEL -- Place Latitude labels next to Latitude circles. +# +# Description +# Since Lines of constant Latitude on a polar graph are usually circles +# around the pole, the lines may never cross edges. Instead, the labels +# are placed next to circles. The grid-drawing routines should setup +# the label position array such that each line has only one label point. + +procedure wl_polar_label (wd) + +pointer wd # I: the WCSLAB descriptor + +int i, prec +pointer sp, label, units, label_format, units_format +real char_height, char_width, ndc_textx, ndc_texty, old_text_size +real textx, texty +int wl_precision() +real gstatr(), ggetr() + +begin + # Get some memory. + call smark (sp) + call salloc (label, SZ_LINE, TY_CHAR) + call salloc (units, SZ_LINE, TY_CHAR) + call salloc (label_format, SZ_LINE, TY_CHAR) + call salloc (units_format, SZ_LINE, TY_CHAR) + + # Get the character height and width. This is used to ensure that we + # have moved the label strings off the border. + + char_height = ggetr (WL_GP(wd), "ch") * gstatr (WL_GP(wd), G_TXSIZE) / + 2. + char_width = ggetr (WL_GP(wd), "cw") * gstatr (WL_GP(wd), G_TXSIZE) / + 2. + + # Get the text size and cut it in half for on the plot labelling. + old_text_size = gstatr (WL_GP(wd), G_TXSIZE) + call gsetr (WL_GP(wd), G_TXSIZE, old_text_size) + call gsetr (WL_GP(wd), G_TXSIZE, old_text_size * 0.80) + + # Determine the precision of the output. + prec = wl_precision (wd, AXIS2) + + # Place the labels. + for (i = 1; i <= WL_N_LABELS(wd); i = i + 1) + if (WL_LABEL_AXIS(wd,i) == AXIS2) { + + # Decode the coordinate into a text string. + call wl_dms (WL_LABEL_VALUE(wd,i), Memc[label], Memc[units], + SZ_LINE, prec, true) + + # Convert text position from "unknown" coordinates to NDC. + call gctran (WL_GP(wd), real (WL_LABEL_POSITION(wd,i,AXIS1)), + real (WL_LABEL_POSITION(wd,i,AXIS2)), ndc_textx, ndc_texty, + WL_PLOT_WCS(wd), WL_NDC_WCS(wd)) + + # Determine the text justification. + switch (WL_POLAR_LABEL_DIRECTION(wd)) { + case BOTTOM: + call strcpy ("h=c;v=t", Memc[label_format], SZ_LINE) + call strcpy ("h=c;v=c", Memc[units_format], SZ_LINE) + ndc_texty = ndc_texty - char_height + case TOP: + call strcpy ("h=c;v=c", Memc[label_format], SZ_LINE) + call strcpy ("h=c;v=b", Memc[units_format], SZ_LINE) + ndc_texty = ndc_texty + char_height + case LEFT: + call strcpy ("h=r;v=c", Memc[label_format], SZ_LINE) + call strcpy ("h=r;v=b", Memc[units_format], SZ_LINE) + ndc_textx = ndc_textx - char_width + case RIGHT: + call strcpy ("h=l;v=c", Memc[label_format], SZ_LINE) + call strcpy ("h=l;v=b", Memc[units_format], SZ_LINE) + ndc_textx = ndc_textx + char_width + } + + # Convert the text position from NDC back to the "unknown" + # system. + call gctran (WL_GP(wd), ndc_textx, ndc_texty, textx, texty, + WL_NDC_WCS(wd), WL_PLOT_WCS(wd)) + + # Print the label. + if (IN (textx, texty)) { + call gtext (WL_GP(wd), textx, texty, Memc[label], + Memc[label_format]) + call gtext (WL_GP(wd), textx, texty, Memc[units], + Memc[units_format]) + } + + } + + # Set the text size back. + call gsetr (WL_GP(wd), G_TXSIZE, old_text_size) + + # Release memory. + call sfree (sp) + +end + + +# Memory management for labels + +define LABEL_LIST Memi[labels+$1-1] + +# WL_LAB_EDGES -- Place labels along the edges of the window. +# +# Description +# Place labels on the specified side of the graph. + +procedure wl_lab_edges (wd, axis, side, offset) + +pointer wd # I: the WCSLAB descriptor +int axis # I: the type of axis being labeled +int side # I: the side to place the labels +real offset # O: offset in NDC units for titles + +bool do_full +double angle, tangle +int i, full_label, nlabels, old_wcs, prec +pointer sp, labels +real ndc_textx, ndc_texty, old_text_size, textx, texty + +int wl_full_label_position(), wl_find_side() +double wl_string_angle(), wl_angle() +int gstati(), wl_precision() +real gstatr() + +begin + call smark (sp) + + # All label placement is done in NDC coordinates. + old_wcs = gstati (WL_GP(wd), G_WCS) + call gseti (WL_GP(wd), G_WCS, WL_NDC_WCS(wd)) + + # Set text labelling size. + old_text_size = gstatr (WL_GP(wd), G_TXSIZE) + call gsetr (WL_GP(wd), G_TXSIZE, WL_LABEL_SIZE(wd)) + + # Get the precision of the axis interval. + prec = wl_precision (wd, axis) + + # Initialize string size. + offset = 0. + + # Build a list of possible labels for this side. The conditions are + # that the label should be for the current axis and that it lies on + # the current side. + + call salloc (labels, WL_N_LABELS(wd), TY_INT) + nlabels = 0 + for (i = 1; i <= WL_N_LABELS(wd); i = i + 1) + if (WL_LABEL_AXIS(wd,i) == axis && + wl_find_side (WL_LABEL_POSITION(wd,i,AXIS1), + WL_LABEL_POSITION(wd,i,AXIS2), + WL_SCREEN_BOUNDARY(wd,1)) == side) { + nlabels = nlabels + 1 + LABEL_LIST(nlabels) = i + } + + # If no labels found, then just forget it. If labels found, well + # write them out. + + if (nlabels != 0) { + + # Determine which label should be written out in full. + full_label = wl_full_label_position (wd, Memi[labels], nlabels, + axis, side, prec) + + # Determine the angle that all the labels will be written at. + if ((WL_LABOUT(wd) == NO) && (WL_GRAPH_TYPE(wd) != NORMAL) && + (WL_LABEL_ROTATE(wd) == YES)) + angle = INDEFR + else if ((WL_GRAPH_TYPE(wd) == NORMAL) && ((WL_LABEL_ROTATE(wd) == + YES) || ((WL_LABOUT(wd) == NO) && (WL_MAJ_GRIDON(wd) == YES)))) + angle = wl_angle (wd, Memi[labels], nlabels) + else + angle = 0.0 + + # Place the labels. + for (i = 1; i <= nlabels; i = i + 1) { + + # Save some pertinent information. + textx = real (WL_LABEL_POSITION(wd,LABEL_LIST(i),AXIS1)) + texty = real (WL_LABEL_POSITION(wd,LABEL_LIST(i),AXIS2)) + do_full = ((LABEL_LIST(i) == full_label) || + (WL_ALWAYS_FULL_LABEL(wd) == YES)) + + # Transform the "unknown" coordinate system to a known + # coordinate system, NDC, for text placement. + call gctran (WL_GP(wd), textx, texty, ndc_textx, ndc_texty, + old_wcs, WL_NDC_WCS(wd)) + + # If angle is undefined, determine the angle for each label. + if (IS_INDEFR(angle)) + tangle = wl_string_angle (WL_LABEL_ANGLE(wd, + LABEL_LIST(i)), WL_LABOUT(wd)) + else + tangle = angle + + # Format and write the label. + call wl_write_label (wd, WL_LABEL_VALUE(wd,LABEL_LIST(i)), + side, ndc_textx, ndc_texty, tangle, axis, prec, do_full, + offset) + } + } + + # Reset the graphics WCS. + call gsetr (WL_GP(wd), G_TXSIZE, old_text_size) + call gseti (WL_GP(wd), G_WCS, old_wcs) + + call sfree (sp) +end + + +# WL_TITLE - Write the title of the graph. + +procedure wl_title (gp, title, side, size, viewport) + +pointer gp # I: the graphics descriptor +char title[ARB] # I: the title to write +int side # I: which side the title will go +real size # I: the character size to write the title +real viewport[N_SIDES] # I: the viewport in NDC to keep the title out of + +int old_wcs +real char_height, char_width, left, right, top, bottom, old_rotation +real old_text_size, x, y +int gstati(), strlen() +real ggetr(), gstatr() + +begin + # Make sure there is a title to write. If not, then punt. + if (strlen (title) <= 0) + return + + # Get/Set pertinent graphics info. + call ggview (gp, left, right, bottom, top) + + old_text_size = gstatr (gp, G_TXSIZE) + call gsetr (gp, G_TXSIZE, size) + old_rotation = gstatr (gp, G_TXUP) + + char_height = ggetr (gp, "ch") * size + char_width = ggetr (gp, "cw") * size + + old_wcs = gstati (gp, G_WCS) + call gseti (gp, G_WCS, NDC_WCS) + + # Depending on side, set text position and rotation. + switch (side) { + case TOP: + call gsetr (gp, G_TXUP, 90.) + x = (right + left) / 2. + y = viewport[TOP] + (2 * char_height) + viewport[TOP] = y + (char_height / 2.) + case BOTTOM: + call gsetr (gp, G_TXUP, 90.) + x = (right + left) / 2. + y = viewport[BOTTOM] - (2 * char_height) + viewport[BOTTOM] = y - (char_height / 2.) + case RIGHT: + call gsetr (gp, G_TXUP, 180.) + x = viewport[RIGHT] + (2 * char_width) + y = (top + bottom) / 2. + viewport[RIGHT] = x + (char_width / 2.) + case LEFT: + call gsetr (gp, G_TXUP, 180.) + x = viewport[LEFT] - (2 * char_width) + y = (top + bottom) / 2. + viewport[LEFT] = x - (char_width / 2.) + } + + # Write the puppy out. + call gtext (gp, x, y, title, "h=c;v=c") + + # Set the graphics state back. + call gseti (gp, G_WCS, old_wcs) + call gsetr (gp, G_TXSIZE, old_text_size) + call gsetr (gp, G_TXUP, old_rotation) +end + + +# WL_PRECISION -- Determine the precision of the interval. + +int procedure wl_precision (wd, axis) + +pointer wd # I: the WCSLAB descriptor +int axis # I: which axis is being examined ? + +int prec + +begin + # Handle the sky coordinates. + if (WL_SYSTEM_TYPE(wd) == RA_DEC) + + if (axis == AXIS1) { + if (WL_MAJOR_INTERVAL(wd,AXIS1) >= STTODEG (3600.0D0)) + prec = HOUR + else if (WL_MAJOR_INTERVAL(wd,AXIS1) >= STTODEG (60.0D0)) + prec = MINUTE + else if (WL_MAJOR_INTERVAL(wd,AXIS1) >= STTODEG (1.0D0)) + prec = SECOND + else if (WL_MAJOR_INTERVAL(wd,AXIS1) >= STTODEG (.01D0)) + prec = SUBSEC_LOW + else + prec = SUBSEC_HIGH + } else { + if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (3600.0D0)) + prec = DEGREE + else if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (60.0D0)) + prec = MINUTE + else if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (1.0D0)) + prec = SECOND + else if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (.01D0)) + prec = SUBSEC_LOW + else + prec = SUBSEC_HIGH + } + + # Handle other coordinate types. + else + prec = INDEFI + + return (prec) + +end + + +# Define some value constraints. + +define LOW_ACCURACY .01 +define HIGH_ACCURACY .0001 + +# WL_HMS -- Convert value to number in hours, minutes, and seconds. + +procedure wl_hms (rarad, hms, units, maxch, precision, all) + +double rarad # I: the value to format into a string (degrees) +char hms[ARB] # O: string containing formatted value +char units[ARB] # O: string containing formatted units +int maxch # I: the maximum number of characters allowed +int precision # I: how precise the output should be +bool all # I: true if all relevent fields should be formatted + +double accuracy, fraction +int sec, h, m, s +pointer sp, temp_hms, temp_units + +begin + # Get some memory. + call smark (sp) + call salloc (temp_hms, maxch, TY_CHAR) + call salloc (temp_units, maxch, TY_CHAR) + + units[1] = EOS + hms[1] = EOS + + # Define how close to zero is needed. + accuracy = LOW_ACCURACY + if (precision == SUBSEC_HIGH) + accuracy = HIGH_ACCURACY + + # Seconds of time. + fraction = double (abs(DEGTOST (rarad))) + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + sec = int (fraction) + fraction = fraction - double (sec) + } else { + sec = int (fraction + 0.5) + fraction = 0. + } + + # Range: 0 to 24 hours. + if (sec < 0) + sec = sec + STPERDAY + else if (sec >= STPERDAY) + sec = mod (sec, STPERDAY) + + # Separater fields. + s = mod (sec, 60) + m = mod (sec / 60, 60) + h = sec / 3600 + + # Format fields. + + # Subseconds. + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + fraction = s + fraction + if (precision == SUBSEC_LOW) { + call sprintf (hms, 6, "%05.2f") + call pargd (fraction) + call strcpy (" s ", units, maxch) + } else { + call sprintf (hms, 8, "%07.4f") + call pargd (fraction) + call strcpy (" s ", units, maxch) + } + if (!all) + all = (fraction < accuracy) + + # Seconds + } else if (precision == SECOND) { + + # NOTE: The all is not part of the if statement because if + # SUBSEC's have been printed, then seconds have already been + # dealt with. If SUBSEC's have not been dealt with, then this + # is the first field to be checked anyways. + + call sprintf (hms, 3, "%02d ") + call pargi (s) + call strcpy (" s", units, maxch) + if (! all) + all = (s == 0) + } + + # Minutes. + if (precision == MINUTE || (precision > MINUTE && all)) { + if (all) { + call strcpy (hms, Memc[temp_hms], maxch) + call strcpy (units, Memc[temp_units], maxch) + } + call sprintf (hms, 3, "%02d ") + call pargi (m) + call strcpy (" m", units, maxch) + if (all) { + call strcat (Memc[temp_hms], hms, maxch) + call strcat (Memc[temp_units], units, maxch) + } else + all = (m == 0) + } + + # Non-zero hours. + if (precision == HOUR || all) { + if (all) { + call strcpy (hms, Memc[temp_hms], maxch) + call strcpy (units, Memc[temp_units], maxch) + } + call sprintf (hms, 3, "%2.2d ") + call pargi (h) + call strcpy(" h", units, maxch) + if (all) { + call strcat (Memc[temp_hms], hms, maxch) + call strcat (Memc[temp_units], units, maxch) + } + } + + # Release memory + call sfree (sp) +end + + +# WL_DMS - Convert value to number in degrees, minutes, and seconds. + +procedure wl_dms (arcrad, dms, units, maxch, precision, all) + +double arcrad # I: the value to format into a string (degrees) +char dms[ARB] # O: string containing formatted value +char units[ARB] # O: string containing formatted units +int maxch # I: the maximum number of characters allowed +int precision # I: how precise the output should be ? +bool all # I: true if all relavent fields should be formatted + +double accuracy, fraction +int sec, h, m, s +pointer sp, temp_dms, temp_units +int strlen() + +begin + # Get some memory. + call smark (sp) + call salloc (temp_dms, maxch, TY_CHAR) + call salloc (temp_units, maxch, TY_CHAR) + + units[1] = EOS + dms[1] = EOS + + # Define how close to zero is needed. + accuracy = LOW_ACCURACY + if (precision == SUBSEC_HIGH) + accuracy = HIGH_ACCURACY + + # Seconds of time. + fraction = double (abs (DEGTOSA (arcrad))) + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + sec = int (fraction) + fraction = fraction - double (sec) + } else { + sec = nint (fraction) + fraction = 0. + } + + # Separater fields. + s = mod (abs(sec), 60) + m = mod (abs(sec) / 60, 60) + h = abs(sec) / 3600 + + # Format fields + # + # Subseconds. + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + + fraction = s + fraction + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + if (precision == SUBSEC_LOW) { + call sprintf (dms, 6, "%05.2f\"") + call pargd (fraction) + call strcpy (" ", units, maxch) + } else { + call sprintf (dms, 8, "%07.4f\"") + call pargd (fraction) + call strcpy (" ", units, maxch) + } + if (! all) + all = (fraction < accuracy) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + + # Seconds + } else if (precision == SECOND) { + + # NOTE: The all is not part of the if statement because if + # SUBSEC's have been printed, then seconds have already been + # dealt with. If SUBSEC's have not been dealt with, then this + # is the first field to be checked anyways. + + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + call sprintf (dms, 3, "%02d\"") + call pargi (s) + call strcpy (" ", units, maxch) + if (! all) + all = (s == 0) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + } + + # Minutes. + if (precision == MINUTE || (precision > MINUTE && all)) { + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + call sprintf (dms, 3, "%02d'") + call pargi (m) + call strcpy (" ", units, maxch) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + if (! all) + all = (m == 0) + } + + # Hours. + if (precision == DEGREE || all) { + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + if (sec + fraction < accuracy) + call strcpy (" 0 ", dms, maxch) + else if (arcrad < 0.) { + call sprintf (dms, 4, "-%d ") + call pargi (h) + } else { + call sprintf (dms, 4, "+%d ") + call pargi (h) + } + call sprintf(units, 4, "%*wo") + call pargi (strlen (dms) - 1) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + } + + # Release memory. + call sfree (sp) +end + + +# WL_FULL_LABEL_POSTION -- Find the position where the full label should be. +# +# Description +# This routine returns the index to the label that should be printed +# in its full form, regardless of its value. This is so there is always +# at least one labelled point with the full information. This point is +# choosen by examining which label is the closest to the passed point +# (usually one of the four corners of the display). +# +# Returns +# Index into the labell arrays of the label to be fully printed. +# If the return index is 0, then there are no labels for the given +# side. + +int procedure wl_full_label_position (wd, labels, nlabels, axis, side, + precision) + +pointer wd # I: the WCSLAB descriptor +int labels[nlabels] # I: array of indexes of labels to be printed +int nlabels # I: the number of labels in labels +int axis # I: the axis being dealt with +int side # I: the side being dealt with +int precision # I: precision of the label + +bool all +double cur_dist, dist +int i, cur_label, xside, yside +pointer sp, temp1 +double wl_distanced() + +begin + # Allocate some working space. + call smark (sp) + call salloc (temp1, SZ_LINE, TY_CHAR) + + # Initialize. + xside = INDEFI + yside = INDEFI + + # Determine which corner will have the full label. + if (side == TOP || side == BOTTOM) { + yside = side + if (axis == AXIS1) { + if (WL_LABEL_SIDE(wd,RIGHT,AXIS2)) + xside = RIGHT + if (WL_LABEL_SIDE(wd,LEFT,AXIS2)) + xside = LEFT + } else { + if (WL_LABEL_SIDE(wd,RIGHT,AXIS1)) + xside = RIGHT + if (WL_LABEL_SIDE(wd,LEFT,AXIS1)) + xside = LEFT + } + if (IS_INDEFI (xside)) + xside = LEFT + } else { + xside = side + if (axis == AXIS1) { + if (WL_LABEL_SIDE(wd,TOP,AXIS2)) + yside = TOP + if (WL_LABEL_SIDE(wd,BOTTOM,AXIS2)) + yside = BOTTOM + } else { + if (WL_LABEL_SIDE(wd,TOP,AXIS1)) + yside = TOP + if (WL_LABEL_SIDE(wd,BOTTOM,AXIS1)) + yside = BOTTOM + } + if (IS_INDEFI (yside)) + yside = BOTTOM + } + + # Find the full label. + cur_label = labels[1] + cur_dist = wl_distanced (WL_SCREEN_BOUNDARY(wd,xside), + WL_SCREEN_BOUNDARY(wd,yside), + WL_LABEL_POSITION(wd,cur_label,AXIS1), + WL_LABEL_POSITION(wd,cur_label,AXIS2)) + + # Now go through the rest of the labels to find a closer label. + for (i = 2; i <= nlabels; i = i + 1) { + + # Check to see if the label would be written in full anyways. + all = false + if (WL_SYSTEM_TYPE(wd) == RA_DEC) { + if (WL_LABEL_AXIS(wd, labels[i]) == LONGITUDE) + call wl_hms (WL_LABEL_VALUE(wd, labels[i]), + Memc[temp1], Memc[temp1], SZ_LINE, precision, all) + else + call wl_dms (WL_LABEL_VALUE(wd, labels[i]), + Memc[temp1], Memc[temp1], SZ_LINE, precision, all) + } + + # If so, don't figure out which label should be full, there + # will be one someplace. + if (all) { + cur_label = INDEFI + break + } + + dist = wl_distanced (WL_SCREEN_BOUNDARY(wd,xside), + WL_SCREEN_BOUNDARY(wd,yside), + WL_LABEL_POSITION(wd,labels[i],AXIS1), + WL_LABEL_POSITION(wd,labels[i],AXIS2)) + if (dist < cur_dist) { + cur_dist = dist + cur_label = labels[i] + } + } + + # Release memory. + call sfree (sp) + + # Return the label index. + return (cur_label) +end + + +# WL_WRITE_LABEL - Write the label in the format specified by the WCS type. + +procedure wl_write_label (wd, value, side, x, y, angle, axis, precision, + do_full, offset) + +pointer wd # I: the WCSLAB descriptor +double value # I: the value to use as the label +int side # I: the side the label is going on +real x, y # I: position of the label in NDC coordinates +double angle # I: the angle the text should be written at +int axis # I: which axis is being labelled +int precision # I: level of precision for labels +bool do_full # I: true if the full label should be printed +real offset # I/O: offset for titles in NDC units + +int tside +pointer sp, label, label_format, units, units_format +real char_height, char_width, in_off_x, in_off_y, length +real lx, ly, new_offset, rx, ry, text_angle +real unit_off_x, unit_off_y, ux, uy + +bool fp_equalr() +double wl_string_angle() +int wl_opposite_side(), strlen() +real ggetr(), gstatr() + +begin + # Get some memory. + call smark (sp) + call salloc (label, SZ_LINE, TY_CHAR) + call salloc (units, SZ_LINE, TY_CHAR) + call salloc (label_format, SZ_LINE, TY_CHAR) + call salloc (units_format, SZ_LINE, TY_CHAR) + + # Get character size. This info is used to move the character string + # by the appropriate amounts. + + char_height = ggetr (WL_GP(wd), "ch") * gstatr (WL_GP(wd), G_TXSIZE) + char_width = ggetr (WL_GP(wd), "cw") * gstatr (WL_GP(wd), G_TXSIZE) + + # Determine the "corrected" angle to write text in. + text_angle = wl_string_angle (angle, WL_LABOUT(wd)) + + # Determine the units offset. + call wl_rotate (0., char_height / 2., 1, text_angle - 90., unit_off_x, + unit_off_y) + + # If the labels are to appear inside the graph and the major grid lines + # have been drawn, then determine the necessary offset to get the label + # off the line. + + if ((WL_LABOUT(wd) == NO) && (WL_MAJ_GRIDON(wd) == YES)) + call wl_rotate (0., 0.75 * char_height, 1, text_angle - 90., + in_off_x, in_off_y) + else { + in_off_x = 0. + in_off_y = 0. + } + + # Decode the coordinate into a text string. + switch (WL_SYSTEM_TYPE(wd)) { + case RA_DEC: + if (axis == LONGITUDE) + call wl_hms (value, Memc[label], Memc[units], SZ_LINE, + precision, do_full) + else + call wl_dms (value, Memc[label], Memc[units], SZ_LINE, + precision, do_full) + default: + call sprintf (Memc[label], SZ_LINE, "%.2g") + call pargd (value) + } + + # Set the text justification. + call sprintf (Memc[label_format], SZ_LINE, "h=c;v=c;u=%f") + call pargr (text_angle) + call sprintf (Memc[units_format], SZ_LINE, "h=c;v=c;u=%f") + call pargr (text_angle) + + # Determine offset needed to rotate text about the point of placement. + # NOTE: The STDGRAPH kernel messes up rotate text placement. Try to + # accomodate with extra offset. + + length = .5 * char_width * (2 + strlen (Memc[label])) + call wl_rotate (length, 0., 1, text_angle - 90., rx, ry) + rx = abs (rx) + ry = abs (ry) + + # If labels are to appear inside the graph, then justification should + # appear as if it were done for the opposite side. + if (WL_LABOUT(wd) == YES) + tside = side + else + tside = wl_opposite_side (side) + + # Now add the offsets appropriately. + switch (tside) { + case TOP: + ly = y + ry + in_off_y + unit_off_y + if (fp_equalr (text_angle, 90.)) { + lx = x + ly = ly + unit_off_y + } else if (text_angle < 90.) + lx = x - rx + else + lx = x + rx + lx = lx + in_off_x + new_offset = ry + ry + + case BOTTOM: + ly = y - ry - in_off_y - unit_off_y + if (fp_equalr (text_angle, 90.)) { + lx = x + ly = ly - unit_off_y + } else if (text_angle < 90.) + lx = x + rx + else + lx = x - rx + lx = lx - in_off_x + new_offset = ry + ry + + case LEFT: + lx = x - rx - abs (unit_off_x) + if (text_angle < 90.) { + ly = y + ry - in_off_y + lx = lx - in_off_x + } else { + ly = y - ry + in_off_y + lx = lx + in_off_x + } + new_offset = rx + rx + abs (unit_off_x) + + case RIGHT: + lx = x + rx + abs (unit_off_x) + if (text_angle < 90.) { + ly = y - ry + in_off_y + lx = lx + in_off_x + } else { + ly = y + ry - in_off_y + lx = lx - in_off_x + } + new_offset = rx + rx + abs (unit_off_x) + } + + lx = lx - (unit_off_x / 2.) + ly = ly - (unit_off_y / 2.) + ux = lx + unit_off_x + uy = ly + unit_off_y + + # Print the label. + call gtext (WL_GP(wd), lx, ly, Memc[label], Memc[label_format]) + + # Print the units (if appropriate). + if (WL_SYSTEM_TYPE(wd) == RA_DEC) + call gtext (WL_GP(wd), ux, uy, Memc[units], Memc[units_format]) + + # Determine new maximum string size. + if ((WL_LABOUT(wd) == YES) && (abs (offset) < new_offset)) + if (side == LEFT || side == BOTTOM) + offset = -new_offset + else + offset = new_offset + + # Release memory. + call sfree (sp) +end + + +# WL_STRING_ANGLE -- Produce the angle that a label string should be written to. +# +# Description +# Fixes the input angle so that the output angle is in the range 0 to 180. +# +# Returns +# the angle that the label should be written as. + +double procedure wl_string_angle (angle, right_to_up) + +double angle # I: the input angle in degrees +int right_to_up # I: true if angle near horizontal/vertical are fixed + +double output_angle + +begin + # Try to ensure that the angle is "upright", i.e. the string will not + # be printed upside-down. + + output_angle = angle + if (output_angle > QUARTER_CIRCLE) + output_angle = output_angle - HALF_CIRCLE + if (output_angle < -QUARTER_CIRCLE) + output_angle = output_angle + HALF_CIRCLE + + # If the angle is close to parallel with one of the axis, then just + # print it normally. + + if ((right_to_up == YES) && ((mod (abs (output_angle), + QUARTER_CIRCLE) < MIN_ANGLE) || (QUARTER_CIRCLE - + mod (abs (output_angle), QUARTER_CIRCLE) < MIN_ANGLE))) + output_angle = 0. + + # Return the angle modified for the idiocincracy of GIO text angle + # specification. + + return (output_angle + QUARTER_CIRCLE) +end + + +# WL_ANGLE -- Return the average angle of the labels in the list. +# +# Returns +# Average angle +# +# Description +# So that labels on a side are uniform (in some sense), the average angle +# of all the labels is taken and is defined as the angle that all the labels +# will be printed at. + +double procedure wl_angle (wd, labels, nlabels) + +pointer wd # I: the WCSLAB descriptor +int labels[nlabels] # I: the indexes of the labels to be printed out +int nlabels # I: the number of indexes in the list + +double total, average +int i + +begin + total = 0.0 + for (i = 1; i <= nlabels; i = i + 1) + total = total + WL_LABEL_ANGLE(wd,labels[i]) + average = real (total / nlabels) + + return (average) +end diff --git a/pkg/utilities/nttools/stxtools/wcslab/wllabel.x.ori b/pkg/utilities/nttools/stxtools/wcslab/wllabel.x.ori new file mode 100644 index 00000000..33e86878 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/wllabel.x.ori @@ -0,0 +1,1077 @@ +include <gset.h> +include <math.h> +include "wcslab.h" +include "wcs_desc.h" + + +# Define the offset array. +define OFFSET Memr[$1+$2-1] + +# WL_LABEL -- Place the labels on the grids. +# +# Description +# Format and write the labels for the grid/tick marks. Much of this +# is wading through conditions to decide whether a label should be +# written or not. + +procedure wl_label (wd) + +pointer wd # I: the WCSLAB descriptor + +bool no_side_axis1, no_side_axis2 +int i, axis1_side, axis2_side +pointer sp, offset_ptr +real offset + +begin + # Get some memory. + call smark (sp) + call salloc (offset_ptr, N_SIDES, TY_REAL) + do i = 1, N_SIDES + OFFSET(offset_ptr,i) = 0. + + # Decide whether any sides were specified for either axis. + no_side_axis1 = true + no_side_axis2 = true + do i = 1, N_SIDES { + if (WL_LABEL_SIDE(wd,i,AXIS1)) + no_side_axis1 = false + if (WL_LABEL_SIDE(wd,i,AXIS2)) + no_side_axis2 = false + } + + # If polar, then label the axis 2's next to their circles on the + # graph and allow the Axis 1s to be labeled on all sides of the graph. + + if (WL_GRAPH_TYPE(wd) == POLAR) { + + call wl_polar_label (wd) + + if (no_side_axis1) { + do i = 1, N_SIDES { + WL_LABEL_SIDE(wd,i,AXIS1) = true + } + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(WD,AXIS1))) + WL_AXIS_TITLE_SIDE(WD,AXIS1) = BOTTOM + } + + # If we are near-polar, label the Axis 2 as if polar, and label + # Axis1 on all sides except the side closest to the pole. + + } else if (WL_GRAPH_TYPE(wd) == NEAR_POLAR) { + + if (no_side_axis1) { + WL_LABEL_SIDE(wd,WL_BAD_LABEL_SIDE(wd),AXIS1) = true + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(wd,AXIS1))) + WL_AXIS_TITLE_SIDE(wd,AXIS1) = WL_BAD_LABEL_SIDE(wd) + } + + if (no_side_axis2) { + WL_LABEL_SIDE(wd,WL_POLAR_LABEL_DIRECTION(wd),AXIS2) = true + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(wd,AXIS2))) + WL_AXIS_TITLE_SIDE(wd,AXIS2) = WL_POLAR_LABEL_DIRECTION(wd) + } + + # Final case- adjacent sides should be labelled. + + } else { + + # Determine the best sides for labelling. + if (INVERT (WL_ROTA(wd))) { + axis1_side = LEFT + axis2_side = BOTTOM + } else { + axis1_side = BOTTOM + axis2_side = LEFT + } + + # If no sides were specified, use the calculated ones above. + if (no_side_axis1) + WL_LABEL_SIDE(wd,axis1_side,AXIS1) = true + if (no_side_axis2) + WL_LABEL_SIDE(wd,axis2_side,AXIS2) = true + } + + # Now draw the labels for axis 1. + do i = 1, N_SIDES { + + if (WL_LABEL_SIDE(wd,i,AXIS1)) { + call wl_lab_edges (wd, AXIS1, i, offset) + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(WD,AXIS1))) + WL_AXIS_TITLE_SIDE(WD,AXIS1) = i + } else + offset = 0. + + # Modify the bounding box for the new viewport. + if (abs (offset) > abs (OFFSET(offset_ptr,i))) + OFFSET(offset_ptr,i) = offset + } + + # Draw the labels for axis 2. + if (WL_GRAPH_TYPE(wd) != POLAR) + do i = 1, N_SIDES { + + if (WL_LABEL_SIDE(wd,i,AXIS2)) { + call wl_lab_edges (wd, AXIS2, i, offset) + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(wd,AXIS2))) + WL_AXIS_TITLE_SIDE(wd,AXIS2) = i + } else + offset = 0. + + # Modify the bounding box for the new viewport. + if (abs (offset) > abs (OFFSET(offset_ptr,i))) + OFFSET(offset_ptr,i) = offset + } + + # Set the bounding box. + do i = 1, N_SIDES + WL_NEW_VIEW(wd,i) = WL_NEW_VIEW(wd,i) + OFFSET(offset_ptr,i) + + # Now write the graph title. + call wl_title (WL_GP(wd), WL_AXIS_TITLE(wd,AXIS1), + WL_AXIS_TITLE_SIDE(wd,AXIS1), WL_AXIS_TITLE_SIZE(wd), + WL_NEW_VIEW(wd,1)) + if (WL_GRAPH_TYPE(wd) != POLAR) + call wl_title (WL_GP(wd), WL_AXIS_TITLE(wd,AXIS2), + WL_AXIS_TITLE_SIDE(wd,AXIS2), WL_AXIS_TITLE_SIZE(WD), + WL_NEW_VIEW(wd,1)) + if (! IS_INDEFI (WL_TITLE_SIDE(wd))) + call wl_title (WL_GP(wd), WL_TITLE(wd), WL_TITLE_SIDE(wd), + WL_TITLE_SIZE(wd), WL_NEW_VIEW(wd,1)) + + # Release memory. + call sfree (sp) +end + + +# Define what is in the screen. + +define IN (($1>WL_SCREEN_BOUNDARY(wd,LEFT))&&($1<WL_SCREEN_BOUNDARY(wd,RIGHT))&&($2>WL_SCREEN_BOUNDARY(wd,BOTTOM))&&($2<WL_SCREEN_BOUNDARY(wd,TOP))) + +# WL_POLAR_LABEL -- Place Latitude labels next to Latitude circles. +# +# Description +# Since Lines of constant Latitude on a polar graph are usually circles +# around the pole, the lines may never cross edges. Instead, the labels +# are placed next to circles. The grid-drawing routines should setup +# the label position array such that each line has only one label point. + +procedure wl_polar_label (wd) + +pointer wd # I: the WCSLAB descriptor + +int i, prec +pointer sp, label, units, label_format, units_format +real char_height, char_width, ndc_textx, ndc_texty, old_text_size +real textx, texty +int wl_precision() +real gstatr(), ggetr() + +begin + # Get some memory. + call smark (sp) + call salloc (label, SZ_LINE, TY_CHAR) + call salloc (units, SZ_LINE, TY_CHAR) + call salloc (label_format, SZ_LINE, TY_CHAR) + call salloc (units_format, SZ_LINE, TY_CHAR) + + # Get the character height and width. This is used to ensure that we + # have moved the label strings off the border. + + char_height = ggetr (WL_GP(wd), "ch") * gstatr (WL_GP(wd), G_TXSIZE) / + 2. + char_width = ggetr (WL_GP(wd), "cw") * gstatr (WL_GP(wd), G_TXSIZE) / + 2. + + # Get the text size and cut it in half for on the plot labelling. + old_text_size = gstatr (WL_GP(wd), G_TXSIZE) + call gsetr (WL_GP(wd), G_TXSIZE, old_text_size) + call gsetr (WL_GP(wd), G_TXSIZE, old_text_size * 0.80) + + # Determine the precision of the output. + prec = wl_precision (wd, AXIS2) + + # Place the labels. + for (i = 1; i <= WL_N_LABELS(wd); i = i + 1) + if (WL_LABEL_AXIS(wd,i) == AXIS2) { + + # Decode the coordinate into a text string. + call wl_dms (WL_LABEL_VALUE(wd,i), Memc[label], Memc[units], + SZ_LINE, prec, true) + + # Convert text position from "unknown" coordinates to NDC. + call gctran (WL_GP(wd), real (WL_LABEL_POSITION(wd,i,AXIS1)), + real (WL_LABEL_POSITION(wd,i,AXIS2)), ndc_textx, ndc_texty, + WL_PLOT_WCS(wd), WL_NDC_WCS(wd)) + + # Determine the text justification. + switch (WL_POLAR_LABEL_DIRECTION(wd)) { + case BOTTOM: + call strcpy ("h=c;v=t", Memc[label_format], SZ_LINE) + call strcpy ("h=c;v=c", Memc[units_format], SZ_LINE) + ndc_texty = ndc_texty - char_height + case TOP: + call strcpy ("h=c;v=c", Memc[label_format], SZ_LINE) + call strcpy ("h=c;v=b", Memc[units_format], SZ_LINE) + ndc_texty = ndc_texty + char_height + case LEFT: + call strcpy ("h=r;v=c", Memc[label_format], SZ_LINE) + call strcpy ("h=r;v=b", Memc[units_format], SZ_LINE) + ndc_textx = ndc_textx - char_width + case RIGHT: + call strcpy ("h=l;v=c", Memc[label_format], SZ_LINE) + call strcpy ("h=l;v=b", Memc[units_format], SZ_LINE) + ndc_textx = ndc_textx + char_width + } + + # Convert the text position from NDC back to the "unknown" + # system. + call gctran (WL_GP(wd), ndc_textx, ndc_texty, textx, texty, + WL_NDC_WCS(wd), WL_PLOT_WCS(wd)) + + # Print the label. + if (IN (textx, texty)) { + call gtext (WL_GP(wd), textx, texty, Memc[label], + Memc[label_format]) + call gtext (WL_GP(wd), textx, texty, Memc[units], + Memc[units_format]) + } + + } + + # Set the text size back. + call gsetr (WL_GP(wd), G_TXSIZE, old_text_size) + + # Release memory. + call sfree (sp) + +end + + +# Memory management for labels + +define LABEL_LIST Memi[labels+$1-1] + +# WL_LAB_EDGES -- Place labels along the edges of the window. +# +# Description +# Place labels on the specified side of the graph. + +procedure wl_lab_edges (wd, axis, side, offset) + +pointer wd # I: the WCSLAB descriptor +int axis # I: the type of axis being labeled +int side # I: the side to place the labels +real offset # O: offset in NDC units for titles + +bool do_full +double angle, tangle +int i, full_label, nlabels, old_wcs, prec +pointer sp, labels +real ndc_textx, ndc_texty, old_text_size, textx, texty + +int wl_full_label_position(), wl_find_side() +double wl_string_angle(), wl_angle() +int gstati(), wl_precision() +real gstatr() + +begin + call smark (sp) + + # All label placement is done in NDC coordinates. + old_wcs = gstati (WL_GP(wd), G_WCS) + call gseti (WL_GP(wd), G_WCS, WL_NDC_WCS(wd)) + + # Set text labelling size. + old_text_size = gstatr (WL_GP(wd), G_TXSIZE) + call gsetr (WL_GP(wd), G_TXSIZE, WL_LABEL_SIZE(wd)) + + # Get the precision of the axis interval. + prec = wl_precision (wd, axis) + + # Initialize string size. + offset = 0. + + # Build a list of possible labels for this side. The conditions are + # that the label should be for the current axis and that it lies on + # the current side. + + call salloc (labels, WL_N_LABELS(wd), TY_INT) + nlabels = 0 + for (i = 1; i <= WL_N_LABELS(wd); i = i + 1) + if (WL_LABEL_AXIS(wd,i) == axis && + wl_find_side (WL_LABEL_POSITION(wd,i,AXIS1), + WL_LABEL_POSITION(wd,i,AXIS2), + WL_SCREEN_BOUNDARY(wd,1)) == side) { + nlabels = nlabels + 1 + LABEL_LIST(nlabels) = i + } + + # If no labels found, then just forget it. If labels found, well + # write them out. + + if (nlabels != 0) { + + # Determine which label should be written out in full. + full_label = wl_full_label_position (wd, Memi[labels], nlabels, + axis, side, prec) + + # Determine the angle that all the labels will be written at. + if ((WL_LABOUT(wd) == NO) && (WL_GRAPH_TYPE(wd) != NORMAL) && + (WL_LABEL_ROTATE(wd) == YES)) + angle = INDEFR + else if ((WL_GRAPH_TYPE(wd) == NORMAL) && ((WL_LABEL_ROTATE(wd) == + YES) || ((WL_LABOUT(wd) == NO) && (WL_MAJ_GRIDON(wd) == YES)))) + angle = wl_angle (wd, Memi[labels], nlabels) + else + angle = 0.0 + + # Place the labels. + for (i = 1; i <= nlabels; i = i + 1) { + + # Save some pertinent information. + textx = real (WL_LABEL_POSITION(wd,LABEL_LIST(i),AXIS1)) + texty = real (WL_LABEL_POSITION(wd,LABEL_LIST(i),AXIS2)) + do_full = ((LABEL_LIST(i) == full_label) || + (WL_ALWAYS_FULL_LABEL(wd) == YES)) + + # Transform the "unknown" coordinate system to a known + # coordinate system, NDC, for text placement. + call gctran (WL_GP(wd), textx, texty, ndc_textx, ndc_texty, + old_wcs, WL_NDC_WCS(wd)) + + # If angle is undefined, determine the angle for each label. + if (IS_INDEFR(angle)) + tangle = wl_string_angle (WL_LABEL_ANGLE(wd, + LABEL_LIST(i)), WL_LABOUT(wd)) + else + tangle = angle + + # Format and write the label. + call wl_write_label (wd, WL_LABEL_VALUE(wd,LABEL_LIST(i)), + side, ndc_textx, ndc_texty, tangle, axis, prec, do_full, + offset) + } + } + + # Reset the graphics WCS. + call gsetr (WL_GP(wd), G_TXSIZE, old_text_size) + call gseti (WL_GP(wd), G_WCS, old_wcs) + + call sfree (sp) +end + + +# WL_TITLE - Write the title of the graph. + +procedure wl_title (gp, title, side, size, viewport) + +pointer gp # I: the graphics descriptor +char title[ARB] # I: the title to write +int side # I: which side the title will go +real size # I: the character size to write the title +real viewport[N_SIDES] # I: the viewport in NDC to keep the title out of + +int old_wcs +real char_height, char_width, left, right, top, bottom, old_rotation +real old_text_size, x, y +int gstati(), strlen() +real ggetr(), gstatr() + +begin + # Make sure there is a title to write. If not, then punt. + if (strlen (title) <= 0) + return + + # Get/Set pertinent graphics info. + call ggview (gp, left, right, bottom, top) + + old_text_size = gstatr (gp, G_TXSIZE) + call gsetr (gp, G_TXSIZE, size) + old_rotation = gstatr (gp, G_TXUP) + + char_height = ggetr (gp, "ch") * size + char_width = ggetr (gp, "cw") * size + + old_wcs = gstati (gp, G_WCS) + call gseti (gp, G_WCS, NDC_WCS) + + # Depending on side, set text position and rotation. + switch (side) { + case TOP: + call gsetr (gp, G_TXUP, 90.) + x = (right + left) / 2. + y = viewport[TOP] + (2 * char_height) + viewport[TOP] = y + (char_height / 2.) + case BOTTOM: + call gsetr (gp, G_TXUP, 90.) + x = (right + left) / 2. + y = viewport[BOTTOM] - (2 * char_height) + viewport[BOTTOM] = y - (char_height / 2.) + case RIGHT: + call gsetr (gp, G_TXUP, 180.) + x = viewport[RIGHT] + (2 * char_width) + y = (top + bottom) / 2. + viewport[RIGHT] = x + (char_width / 2.) + case LEFT: + call gsetr (gp, G_TXUP, 180.) + x = viewport[LEFT] - (2 * char_width) + y = (top + bottom) / 2. + viewport[LEFT] = x - (char_width / 2.) + } + + # Write the puppy out. + call gtext (gp, x, y, title, "h=c;v=c") + + # Set the graphics state back. + call gseti (gp, G_WCS, old_wcs) + call gsetr (gp, G_TXSIZE, old_text_size) + call gsetr (gp, G_TXUP, old_rotation) +end + + +# WL_PRECISION -- Determine the precision of the interval. + +int procedure wl_precision (wd, axis) + +pointer wd # I: the WCSLAB descriptor +int axis # I: which axis is being examined ? + +int prec + +begin + # Handle the sky coordinates. + if (WL_SYSTEM_TYPE(wd) == RA_DEC) + + if (axis == AXIS1) { + if (WL_MAJOR_INTERVAL(wd,AXIS1) >= STTODEG (3600.0D0)) + prec = HOUR + else if (WL_MAJOR_INTERVAL(wd,AXIS1) >= STTODEG (60.0D0)) + prec = MINUTE + else if (WL_MAJOR_INTERVAL(wd,AXIS1) >= STTODEG (1.0D0)) + prec = SECOND + else if (WL_MAJOR_INTERVAL(wd,AXIS1) >= STTODEG (.01D0)) + prec = SUBSEC_LOW + else + prec = SUBSEC_HIGH + } else { + if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (3600.0D0)) + prec = DEGREE + else if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (60.0D0)) + prec = MINUTE + else if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (1.0D0)) + prec = SECOND + else if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (.01D0)) + prec = SUBSEC_LOW + else + prec = SUBSEC_HIGH + } + + # Handle other coordinate types. + else + prec = INDEFI + + return (prec) + +end + + +# Define some value constraints. + +define LOW_ACCURACY .01 +define HIGH_ACCURACY .0001 + +# WL_HMS -- Convert value to number in hours, minutes, and seconds. + +procedure wl_hms (rarad, hms, units, maxch, precision, all) + +double rarad # I: the value to format into a string (degrees) +char hms[ARB] # O: string containing formatted value +char units[ARB] # O: string containing formatted units +int maxch # I: the maximum number of characters allowed +int precision # I: how precise the output should be +bool all # I: true if all relevent fields should be formatted + +double accuracy, fraction +int sec, h, m, s +pointer sp, temp_hms, temp_units + +begin + # Get some memory. + call smark (sp) + call salloc (temp_hms, maxch, TY_CHAR) + call salloc (temp_units, maxch, TY_CHAR) + + units[1] = EOS + hms[1] = EOS + + # Define how close to zero is needed. + accuracy = LOW_ACCURACY + if (precision == SUBSEC_HIGH) + accuracy = HIGH_ACCURACY + + # Seconds of time. + fraction = double (abs(DEGTOST (rarad))) + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + sec = int (fraction) + fraction = fraction - double (sec) + } else { + sec = int (fraction + 0.5) + fraction = 0. + } + + # Range: 0 to 24 hours. + if (sec < 0) + sec = sec + STPERDAY + else if (sec >= STPERDAY) + sec = mod (sec, STPERDAY) + + # Separater fields. + s = mod (sec, 60) + m = mod (sec / 60, 60) + h = sec / 3600 + + # Format fields. + + # Subseconds. + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + fraction = s + fraction + if (precision == SUBSEC_LOW) { + call sprintf (hms, 6, "%05.2f") + call pargd (fraction) + call strcpy (" s ", units, maxch) + } else { + call sprintf (hms, 8, "%07.4f") + call pargd (fraction) + call strcpy (" s ", units, maxch) + } + if (!all) + all = (fraction < accuracy) + + # Seconds + } else if (precision == SECOND) { + + # NOTE: The all is not part of the if statement because if + # SUBSEC's have been printed, then seconds have already been + # dealt with. If SUBSEC's have not been dealt with, then this + # is the first field to be checked anyways. + + call sprintf (hms, 3, "%02d ") + call pargi (s) + call strcpy (" s", units, maxch) + if (! all) + all = (s == 0) + } + + # Minutes. + if (precision == MINUTE || (precision > MINUTE && all)) { + if (all) { + call strcpy (hms, Memc[temp_hms], maxch) + call strcpy (units, Memc[temp_units], maxch) + } + call sprintf (hms, 3, "%02d ") + call pargi (m) + call strcpy (" m", units, maxch) + if (all) { + call strcat (Memc[temp_hms], hms, maxch) + call strcat (Memc[temp_units], units, maxch) + } else + all = (m == 0) + } + + # Non-zero hours. + if (precision == HOUR || all) { + if (all) { + call strcpy (hms, Memc[temp_hms], maxch) + call strcpy (units, Memc[temp_units], maxch) + } + call sprintf (hms, 3, "%2.2d ") + call pargi (h) + call strcpy(" h", units, maxch) + if (all) { + call strcat (Memc[temp_hms], hms, maxch) + call strcat (Memc[temp_units], units, maxch) + } + } + + # Release memory + call sfree (sp) +end + + +# WL_DMS - Convert value to number in degrees, minutes, and seconds. + +procedure wl_dms (arcrad, dms, units, maxch, precision, all) + +double arcrad # I: the value to format into a string (degrees) +char dms[ARB] # O: string containing formatted value +char units[ARB] # O: string containing formatted units +int maxch # I: the maximum number of characters allowed +int precision # I: how precise the output should be ? +bool all # I: true if all relavent fields should be formatted + +double accuracy, fraction +int sec, h, m, s +pointer sp, temp_dms, temp_units +int strlen() + +begin + # Get some memory. + call smark (sp) + call salloc (temp_dms, maxch, TY_CHAR) + call salloc (temp_units, maxch, TY_CHAR) + + units[1] = EOS + dms[1] = EOS + + # Define how close to zero is needed. + accuracy = LOW_ACCURACY + if (precision == SUBSEC_HIGH) + accuracy = HIGH_ACCURACY + + # Seconds of time. + fraction = double (abs (DEGTOSA (arcrad))) + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + sec = int (fraction) + fraction = fraction - double (sec) + } else { + sec = nint (fraction) + fraction = 0. + } + + # Separater fields. + s = mod (abs(sec), 60) + m = mod (abs(sec) / 60, 60) + h = abs(sec) / 3600 + + # Format fields + # + # Subseconds. + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + + fraction = s + fraction + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + if (precision == SUBSEC_LOW) { + call sprintf (dms, 6, "%05.2f\"") + call pargd (fraction) + call strcpy (" ", units, maxch) + } else { + call sprintf (dms, 8, "%07.4f\"") + call pargd (fraction) + call strcpy (" ", units, maxch) + } + if (! all) + all = (fraction < accuracy) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + + # Seconds + } else if (precision == SECOND) { + + # NOTE: The all is not part of the if statement because if + # SUBSEC's have been printed, then seconds have already been + # dealt with. If SUBSEC's have not been dealt with, then this + # is the first field to be checked anyways. + + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + call sprintf (dms, 3, "%02d\"") + call pargi (s) + call strcpy (" ", units, maxch) + if (! all) + all = (s == 0) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + } + + # Minutes. + if (precision == MINUTE || (precision > MINUTE && all)) { + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + call sprintf (dms, 3, "%02d'") + call pargi (m) + call strcpy (" ", units, maxch) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + if (! all) + all = (m == 0) + } + + # Hours. + if (precision == DEGREE || all) { + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + if (sec + fraction < accuracy) + call strcpy (" 0 ", dms, maxch) + else if (arcrad < 0.) { + call sprintf (dms, 4, "-%d ") + call pargi (h) + } else { + call sprintf (dms, 4, "+%d ") + call pargi (h) + } + call sprintf(units, 4, "%*wo") + call pargi (strlen (dms) - 1) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + } + + # Release memory. + call sfree (sp) +end + + +# WL_FULL_LABEL_POSTION -- Find the position where the full label should be. +# +# Description +# This routine returns the index to the label that should be printed +# in its full form, regardless of its value. This is so there is always +# at least one labelled point with the full information. This point is +# choosen by examining which label is the closest to the passed point +# (usually one of the four corners of the display). +# +# Returns +# Index into the labell arrays of the label to be fully printed. +# If the return index is 0, then there are no labels for the given +# side. + +int procedure wl_full_label_position (wd, labels, nlabels, axis, side, + precision) + +pointer wd # I: the WCSLAB descriptor +int labels[nlabels] # I: array of indexes of labels to be printed +int nlabels # I: the number of labels in labels +int axis # I: the axis being dealt with +int side # I: the side being dealt with +int precision # I: precision of the label + +bool all +double cur_dist, dist +int i, cur_label, xside, yside +pointer sp, temp1 +double wl_distanced() + +begin + # Allocate some working space. + call smark (sp) + call salloc (temp1, SZ_LINE, TY_CHAR) + + # Initialize. + xside = INDEFI + yside = INDEFI + + # Determine which corner will have the full label. + if (side == TOP || side == BOTTOM) { + yside = side + if (axis == AXIS1) { + if (WL_LABEL_SIDE(wd,RIGHT,AXIS2)) + xside = RIGHT + if (WL_LABEL_SIDE(wd,LEFT,AXIS2)) + xside = LEFT + } else { + if (WL_LABEL_SIDE(wd,RIGHT,AXIS1)) + xside = RIGHT + if (WL_LABEL_SIDE(wd,LEFT,AXIS1)) + xside = LEFT + } + if (IS_INDEFI (xside)) + xside = LEFT + } else { + xside = side + if (axis == AXIS1) { + if (WL_LABEL_SIDE(wd,TOP,AXIS2)) + yside = TOP + if (WL_LABEL_SIDE(wd,BOTTOM,AXIS2)) + yside = BOTTOM + } else { + if (WL_LABEL_SIDE(wd,TOP,AXIS1)) + yside = TOP + if (WL_LABEL_SIDE(wd,BOTTOM,AXIS1)) + yside = BOTTOM + } + if (IS_INDEFI (yside)) + yside = BOTTOM + } + + # Find the full label. + cur_label = labels[1] + cur_dist = wl_distanced (WL_SCREEN_BOUNDARY(wd,xside), + WL_SCREEN_BOUNDARY(wd,yside), + WL_LABEL_POSITION(wd,cur_label,AXIS1), + WL_LABEL_POSITION(wd,cur_label,AXIS2)) + + # Now go through the rest of the labels to find a closer label. + for (i = 2; i <= nlabels; i = i + 1) { + + # Check to see if the label would be written in full anyways. + all = false + if (WL_SYSTEM_TYPE(wd) == RA_DEC) { + if (WL_LABEL_AXIS(wd, labels[i]) == LONGITUDE) + call wl_hms (WL_LABEL_VALUE(wd, labels[i]), + Memc[temp1], Memc[temp1], SZ_LINE, precision, all) + else + call wl_dms (WL_LABEL_VALUE(wd, labels[i]), + Memc[temp1], Memc[temp1], SZ_LINE, precision, all) + } + + # If so, don't figure out which label should be full, there + # will be one someplace. + if (all) { + cur_label = INDEFI + break + } + + dist = wl_distanced (WL_SCREEN_BOUNDARY(wd,xside), + WL_SCREEN_BOUNDARY(wd,yside), + WL_LABEL_POSITION(wd,labels[i],AXIS1), + WL_LABEL_POSITION(wd,labels[i],AXIS2)) + if (dist < cur_dist) { + cur_dist = dist + cur_label = labels[i] + } + } + + # Release memory. + call sfree (sp) + + # Return the label index. + return (cur_label) +end + + +# WL_WRITE_LABEL - Write the label in the format specified by the WCS type. + +procedure wl_write_label (wd, value, side, x, y, angle, axis, precision, + do_full, offset) + +pointer wd # I: the WCSLAB descriptor +double value # I: the value to use as the label +int side # I: the side the label is going on +real x, y # I: position of the label in NDC coordinates +double angle # I: the angle the text should be written at +int axis # I: which axis is being labelled +int precision # I: level of precision for labels +bool do_full # I: true if the full label should be printed +real offset # I/O: offset for titles in NDC units + +int tside +pointer sp, label, label_format, units, units_format +real char_height, char_width, in_off_x, in_off_y, length +real lx, ly, new_offset, rx, ry, text_angle +real unit_off_x, unit_off_y, ux, uy + +bool fp_equalr() +double wl_string_angle() +int wl_opposite_side(), strlen() +real ggetr(), gstatr() + +begin + # Get some memory. + call smark (sp) + call salloc (label, SZ_LINE, TY_CHAR) + call salloc (units, SZ_LINE, TY_CHAR) + call salloc (label_format, SZ_LINE, TY_CHAR) + call salloc (units_format, SZ_LINE, TY_CHAR) + + # Get character size. This info is used to move the character string + # by the appropriate amounts. + + char_height = ggetr (WL_GP(wd), "ch") * gstatr (WL_GP(wd), G_TXSIZE) + char_width = ggetr (WL_GP(wd), "cw") * gstatr (WL_GP(wd), G_TXSIZE) + + # Determine the "corrected" angle to write text in. + text_angle = wl_string_angle (angle, WL_LABOUT(wd)) + + # Determine the units offset. + call wl_rotate (0., char_height / 2., 1, text_angle - 90., unit_off_x, + unit_off_y) + + # If the labels are to appear inside the graph and the major grid lines + # have been drawn, then determine the necessary offset to get the label + # off the line. + + if ((WL_LABOUT(wd) == NO) && (WL_MAJ_GRIDON(wd) == YES)) + call wl_rotate (0., 0.75 * char_height, 1, text_angle - 90., + in_off_x, in_off_y) + else { + in_off_x = 0. + in_off_y = 0. + } + + # Decode the coordinate into a text string. + switch (WL_SYSTEM_TYPE(wd)) { + case RA_DEC: + if (axis == LONGITUDE) + call wl_hms (value, Memc[label], Memc[units], SZ_LINE, + precision, do_full) + else + call wl_dms (value, Memc[label], Memc[units], SZ_LINE, + precision, do_full) + default: + call sprintf (Memc[label], SZ_LINE, "%.2g") + call pargd (value) + } + + # Set the text justification. + call sprintf (Memc[label_format], SZ_LINE, "h=c;v=c;u=%f") + call pargr (text_angle) + call sprintf (Memc[units_format], SZ_LINE, "h=c;v=c;u=%f") + call pargr (text_angle) + + # Determine offset needed to rotate text about the point of placement. + # NOTE: The STDGRAPH kernel messes up rotate text placement. Try to + # accomodate with extra offset. + + length = .5 * char_width * (2 + strlen (Memc[label])) + call wl_rotate (length, 0., 1, text_angle - 90., rx, ry) + rx = abs (rx) + ry = abs (ry) + + # If labels are to appear inside the graph, then justification should + # appear as if it were done for the opposite side. + if (WL_LABOUT(wd) == YES) + tside = side + else + tside = wl_opposite_side (side) + + # Now add the offsets appropriately. + switch (tside) { + case TOP: + ly = y + ry + in_off_y + unit_off_y + if (fp_equalr (text_angle, 90.)) { + lx = x + ly = ly + unit_off_y + } else if (text_angle < 90.) + lx = x - rx + else + lx = x + rx + lx = lx + in_off_x + new_offset = ry + ry + + case BOTTOM: + ly = y - ry - in_off_y - unit_off_y + if (fp_equalr (text_angle, 90.)) { + lx = x + ly = ly - unit_off_y + } else if (text_angle < 90.) + lx = x + rx + else + lx = x - rx + lx = lx - in_off_x + new_offset = ry + ry + + case LEFT: + lx = x - rx - abs (unit_off_x) + if (text_angle < 90.) { + ly = y + ry - in_off_y + lx = lx - in_off_x + } else { + ly = y - ry + in_off_y + lx = lx + in_off_x + } + new_offset = rx + rx + abs (unit_off_x) + + case RIGHT: + lx = x + rx + abs (unit_off_x) + if (text_angle < 90.) { + ly = y - ry + in_off_y + lx = lx + in_off_x + } else { + ly = y + ry - in_off_y + lx = lx - in_off_x + } + new_offset = rx + rx + abs (unit_off_x) + } + + lx = lx - (unit_off_x / 2.) + ly = ly - (unit_off_y / 2.) + ux = lx + unit_off_x + uy = ly + unit_off_y + + # Print the label. + call gtext (WL_GP(wd), lx, ly, Memc[label], Memc[label_format]) + + # Print the units (if appropriate). + if (WL_SYSTEM_TYPE(wd) == RA_DEC) + call gtext (WL_GP(wd), ux, uy, Memc[units], Memc[units_format]) + + # Determine new maximum string size. + if ((WL_LABOUT(wd) == YES) && (abs (offset) < new_offset)) + if (side == LEFT || side == BOTTOM) + offset = -new_offset + else + offset = new_offset + + # Release memory. + call sfree (sp) +end + + +# WL_STRING_ANGLE -- Produce the angle that a label string should be written to. +# +# Description +# Fixes the input angle so that the output angle is in the range 0 to 180. +# +# Returns +# the angle that the label should be written as. + +double procedure wl_string_angle (angle, right_to_up) + +double angle # I: the input angle in degrees +int right_to_up # I: true if angle near horizontal/vertical are fixed + +double output_angle + +begin + # Try to ensure that the angle is "upright", i.e. the string will not + # be printed upside-down. + + output_angle = angle + if (output_angle > QUARTER_CIRCLE) + output_angle = output_angle - HALF_CIRCLE + if (output_angle < -QUARTER_CIRCLE) + output_angle = output_angle + HALF_CIRCLE + + # If the angle is close to parallel with one of the axis, then just + # print it normally. + + if ((right_to_up == YES) && ((mod (abs (output_angle), + QUARTER_CIRCLE) < MIN_ANGLE) || (QUARTER_CIRCLE - + mod (abs (output_angle), QUARTER_CIRCLE) < MIN_ANGLE))) + output_angle = 0. + + # Return the angle modified for the idiocincracy of GIO text angle + # specification. + + return (output_angle + QUARTER_CIRCLE) +end + + +# WL_ANGLE -- Return the average angle of the labels in the list. +# +# Returns +# Average angle +# +# Description +# So that labels on a side are uniform (in some sense), the average angle +# of all the labels is taken and is defined as the angle that all the labels +# will be printed at. + +double procedure wl_angle (wd, labels, nlabels) + +pointer wd # I: the WCSLAB descriptor +int labels[nlabels] # I: the indexes of the labels to be printed out +int nlabels # I: the number of indexes in the list + +double total, average +int i + +begin + total = 0.0 + for (i = 1; i <= nlabels; i = i + 1) + total = total + WL_LABEL_ANGLE(wd,labels[i]) + average = real (total / nlabels) + + return (average) +end diff --git a/pkg/utilities/nttools/stxtools/wcslab/wlsetup.x b/pkg/utilities/nttools/stxtools/wcslab/wlsetup.x new file mode 100644 index 00000000..c37e24ca --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/wlsetup.x @@ -0,0 +1,1000 @@ +include <gset.h> +include <mach.h> +include <math.h> +include <math/curfit.h> +include "wcslab.h" +include "wcs_desc.h" + +# WL_SETUP -- Determine all the basic characteristics of the plot. +# +# Description +# Determine basic characteristics of the plot at hand. This involved +# "discovering" what part of the world system covers the screen, the +# orientation of the world to logical systems, what type of graph will +# be produced, etc. Many of the parameters determined here can be +# over-ridden by user-specified values. + +procedure wl_setup (wd) + +pointer wd # I: the WCSLAB descriptor + +bool north +double array[N_EDGES,N_DIM], max_value[N_DIM], min_value[N_DIM] +double range[N_DIM], pole_position[N_DIM], view_edge[N_EDGES,N_DIM] +double wl_coord_rotation() +pointer mw_sctran() +string logtran "logical" +string wrldtran "world" + +begin + # Calculate the transformations from the Logical (pixel space) system + # to the World (possibly anything) system and back. + WL_LWCT(wd) = mw_sctran (WL_MW(wd), logtran, wrldtran, AXIS) + WL_WLCT(wd) = mw_sctran (WL_MW(wd), wrldtran, logtran, AXIS) + + # Indicate whether the center of the transformation is north. + if (WL_SYSTEM_TYPE(wd) == RA_DEC) + north = (WL_WORLD_CENTER(wd,LATITUDE) > 0.0D0) + + # Determine the poles position. + if (WL_SYSTEM_TYPE(wd) == RA_DEC) + call wl_pole_position (WL_WLCT(wd), WL_AXIS_FLIP(wd), + WL_WORLD_CENTER(wd,LONGITUDE), north, WL_SYSTEM_TYPE(wd), + pole_position) + + # Determine graph type based on the system type. + call wl_determine_graph_type (WL_SYSTEM_TYPE(wd), pole_position, + WL_SCREEN_BOUNDARY(wd,1), WL_GRAPH_TYPE(wd)) + + # Now find the extent of the WCS the window views, by constructing + # x,y vectors containing evenly spaced points around the edges of + # the viewing window. + + call wl_construct_edge_vectors (WL_SCREEN_BOUNDARY(wd,1), + view_edge[1,X_DIM], view_edge[1,Y_DIM], N_EDGES) + + # Find the range of the axes over the graphics viewport. + call wl_l2wd (WL_LWCT(wd), WL_AXIS_FLIP(wd), view_edge[1,X_DIM], + view_edge[1,Y_DIM], array[1,AXIS1], array[1,AXIS2], N_EDGES) + call alimd (array[1,AXIS1], N_EDGES, min_value[AXIS1], max_value[AXIS1]) + call alimd (array[1,AXIS2], N_EDGES, min_value[AXIS2], max_value[AXIS2]) + range[AXIS1] = abs (max_value[AXIS1] - min_value[AXIS1]) + range[AXIS2] = abs (max_value[AXIS2] - min_value[AXIS2]) + + # The above isn't good enough for the sky projections. Deal with those. + if (WL_SYSTEM_TYPE(wd) == RA_DEC) + call wl_sky_extrema (wd, array[1,AXIS1], N_EDGES, pole_position, + north, min_value[AXIS1], max_value[AXIS1], range[AXIS1], + min_value[AXIS2], max_value[AXIS2], range[AXIS2]) + + # Determine the rotation between the systems. + WL_ROTA(wd) = wl_coord_rotation (WL_WLCT(wd), WL_AXIS_FLIP(wd), + WL_WORLD_CENTER(wd,AXIS1), max_value[AXIS2], + WL_WORLD_CENTER(wd,AXIS1), min_value[AXIS2]) + + # Round the intervals. This is done to make the labelling "nice" and + # to smooth edge effects. + if (IS_INDEFD (WL_MAJOR_INTERVAL(wd,AXIS1)) || + IS_INDEFD (WL_BEGIN(wd,AXIS1)) || IS_INDEFD (WL_END(wd,AXIS1))) + call wl_round_axis (wd, AXIS1, min_value[AXIS1], max_value[AXIS1], + range[AXIS1]) + + if (IS_INDEFD (WL_MAJOR_INTERVAL(wd,AXIS2)) || + IS_INDEFD (WL_BEGIN(wd,AXIS2)) || IS_INDEFD (WL_END(wd,AXIS2))) + call wl_round_axis (wd, AXIS2, min_value[AXIS2], max_value[AXIS2], + range[AXIS2]) +end + + +# WL_POLE_POSITION -- Determine logical coordinates of a pole. +# +# Description +# Calculate the pole's position in the Logical system. +# +# Bugs +# Can only deal with Right Ascension/Declination. + +procedure wl_pole_position (wlct, flip, longitude, north, system_type, + pole_position) + +pointer wlct # I: the world-to-logical transformation +int flip # I: true if the axes are transposed +double longitude # I: the longitude to determine latitude +bool north # I: true if the pole is in the north +int system_type # I: type of system being examined +double pole_position[N_DIM] # O: the pole's logical coordinates + +double sgn + +begin + switch (system_type) { + + # For Right Ascension/Declination, the pole is at any longitude but + # at only 90 degrees (north) or -90 degrees (south) latitude. + case RA_DEC: + if (north) + sgn = NORTH_POLE_LATITUDE + else + sgn = SOUTH_POLE_LATITUDE + call wl_w2ld (wlct, flip, longitude, sgn, pole_position[X_DIM], + pole_position[Y_DIM], 1) + } + + # Sanity check on the pole position. It is very likely that there is + # no valid position in pixel space for the pole. This is checked for + # by looking for extremely large numbers. + if (abs (pole_position[X_DIM]) > abs (double (MAX_INT))) + pole_position[X_DIM] = real (MAX_INT) + if (abs (pole_position[Y_DIM]) > abs (double (MAX_INT))) + pole_position[Y_DIM] = real (MAX_INT) +end + + +# How close can the pole be to the center of the screen to be near-polar. +define HOW_CLOSE 3. + +# WL_DETERMINE_GRAPH_TYPE -- Determine the actual graph type. + +procedure wl_determine_graph_type (system_type, pole_position, + screen_boundary, graph_type) + +int system_type # I: the type of WCS being dealt with +double pole_position[N_DIM] # I: the location of the pole +double screen_boundary[N_SIDES] # I: the edges of the display +int graph_type # O: the graph type + +double max_dist, pole_dist, xcen, ycen + +begin + # Determine graph type based on axis type. + switch (system_type) { + + # If the pole is on the graph then force a graph_type of polar. + case RA_DEC: + + xcen = (screen_boundary[LEFT] + screen_boundary[RIGHT]) / 2. + ycen = (screen_boundary[BOTTOM] + screen_boundary[TOP]) / 2. + max_dist = min ((screen_boundary[LEFT] - xcen) ** 2, + (screen_boundary[TOP] - ycen)**2) + pole_dist = (pole_position[X_DIM] - xcen) ** 2 + + (pole_position[Y_DIM] - ycen) ** 2 + + # Check to see whether the graph is "polar", "near_polar" + # or "normal". If the pole lies within middle part of the + # viewport, then the graph is "polar". If the pole is within + # a certain maximum distance then it is "near_polar". + # Otherwise it is normal. + + switch (graph_type) { + case NORMAL: + # do nothing + case POLAR: + # do nothing + case NEAR_POLAR: + # do nothing + default: + if (pole_dist < max_dist) + graph_type = POLAR + else if (pole_dist < HOW_CLOSE * max_dist) + graph_type = NEAR_POLAR + else + graph_type = NORMAL + } + + # For all other cases, explicitely set this to normal. + default: + graph_type = NORMAL + } +end + + +# WL_CONSTRUCT_EDGE_VECTORS -- Construct vectors of values along window's edge. +# +# Description +# This routines filles two arrays, with the x-values and y-values of +# evenly spaced points along the edges of the screen. This is used to +# make transformation of the logical edges into the world system +# more convenient. + +procedure wl_construct_edge_vectors (screen_boundary, x, y, vector_size) + +double screen_boundary[N_SIDES] # I: the side values +double x[vector_size], y[vector_size] # O: the edge vector points +int vector_size # I: the number of edge vector points + +double current, interval +int i, left_over, offset1, offset2, side_length + +begin + # Divide the vectors into equal amounts for each side. + side_length = vector_size / N_SIDES + left_over = mod (vector_size, N_SIDES) + + # Calculate the horizontal components. + interval = (screen_boundary[RIGHT] - screen_boundary[LEFT]) / + side_length + current = screen_boundary[LEFT] + offset1 = side_length + for (i = 1; i <= side_length; i = i + 1) { + x[i] = current + interval + y[i] = screen_boundary[BOTTOM] + x[i+offset1] = current + y[i+offset1] = screen_boundary[TOP] + current = current + interval + } + + # Calculate the verticle components. + interval = (screen_boundary[TOP] - screen_boundary[BOTTOM]) / + side_length + current = screen_boundary[BOTTOM] + offset1 = 2 * side_length + offset2 = 3 * side_length + for (i = 1; i <= side_length; i = i + 1) { + x[i+offset1] = screen_boundary[LEFT] + y[i+offset1] = current + x[i+offset2] = screen_boundary[RIGHT] + y[i+offset2] = current + interval + current = current + interval + } + + # Fill in the left over with a single point. + offset1 = 4 * side_length + for (i = 1; i <= left_over; i = i + 1) { + x[i+offset1] = screen_boundary[LEFT] + y[i+offset1] = screen_boundary[BOTTOM] + } + +end + + +# WL_SKY_EXTREMA -- Determine what range the view window covers in the sky. +# This routine is only called if the WCS RA,DEC. +# +# Description +# Because of the different graph types and the fact that axis 1 usually +# wraps, more work needs to be done to determine what part of the sky +# is covered by the viewing window. + +procedure wl_sky_extrema (wd, ax1_array, n_points, pole_position, north, + ax1min, ax1max, ax1ran, ax2min, ax2max, ax2ran) + +pointer wd # I: the WCSLAB descriptor +double ax1_array[n_points] # I: the axis 1 edge vector +int n_points # I: the length of the edge vector +double pole_position[N_DIM] # I: the pole position +bool north # I: is the pole in the north ? +double ax1min, ax1max, ax1ran # I/O: the minimum, maximum, range in axis 1 +double ax2min, ax2max, ax2ran # I/O: the minimum, maximum, range in axis 2 + +bool is_pole +double nx, ny, xcen, ycen +int wl_direction_from_axis1(), wl_find_side(), wl_opposite_side() + +begin + # Is the pole on the graph ? + if ((pole_position[X_DIM] < WL_SCREEN_BOUNDARY(wd,LEFT)) || + (pole_position[X_DIM] > WL_SCREEN_BOUNDARY(wd,RIGHT)) || + (pole_position[Y_DIM] < WL_SCREEN_BOUNDARY(wd,BOTTOM)) || + (pole_position[Y_DIM] > WL_SCREEN_BOUNDARY(wd,TOP))) + is_pole = false + else + is_pole = true + + # If so adjust the RA and DEC ranges appropriately. + if (is_pole) { + + # Set the RA range. + ax1min = 0.0D0 + ax1max = 359.9D0 + ax1ran = 360.0D0 + + # Set the dec range. + if (north) + ax2max = NORTH_POLE_LATITUDE - ((NORTH_POLE_LATITUDE - + ax2min) * DISTANCE_TO_POLE ) + else + ax2min = SOUTH_POLE_LATITUDE + ((NORTH_POLE_LATITUDE + + ax2max) * DISTANCE_TO_POLE) + ax2ran = abs (ax2max - ax2min) + + # Mark the pole. + call gmark (WL_GP(wd), real (pole_position[X_DIM]), + real (pole_position[Y_DIM]), POLE_MARK_SHAPE, POLE_MARK_SIZE, + POLE_MARK_SIZE) + + } else { + # Only the RA range needs adjusting. + call wl_ra_range (ax1_array, n_points, ax1min, ax1max, ax1ran) + } + + # Adjust the labelling characteristics appropritatley for various + # types of graphs. + + if (WL_GRAPH_TYPE(wd) == POLAR) { + + # Determine which direction the axis 2's will be labeled on polar + # graphs. + if (IS_INDEFD (WL_POLAR_LABEL_POSITION(wd))) { + call wl_get_axis2_label_direction (WL_LWCT(wd), + WL_AXIS_FLIP(wd), pole_position, WL_SCREEN_BOUNDARY(wd,1), + WL_POLAR_LABEL_POSITION(wd), WL_BAD_LABEL_SIDE(wd)) + } else { + WL_BAD_LABEL_SIDE(wd) = wl_direction_from_axis1 (WL_WLCT(wd), + WL_AXIS_FLIP(wd), pole_position, north, + WL_POLAR_LABEL_POSITION(wd), WL_BEGIN(wd,AXIS2), + WL_END(wd,AXIS2), WL_SCREEN_BOUNDARY(wd,1)) + if (IS_INDEFI (WL_BAD_LABEL_SIDE(wd))) + WL_BAD_LABEL_SIDE(wd) = BOTTOM + } + + # If the graph type is polar, then determine how to justify + # the labels. + + if (IS_INDEFI (WL_POLAR_LABEL_DIRECTION(wd))) + WL_POLAR_LABEL_DIRECTION(wd) = + wl_opposite_side (WL_BAD_LABEL_SIDE(wd)) + + # If the graph_type is near-polar, then handle the directions a bit + # differently. + } else if (WL_GRAPH_TYPE(wd) == NEAR_POLAR) { + + # Find the side that the pole is on. + xcen = (WL_SCREEN_BOUNDARY(wd,LEFT) + + WL_SCREEN_BOUNDARY(wd,RIGHT)) / 2. + ycen = (WL_SCREEN_BOUNDARY(wd,BOTTOM) + + WL_SCREEN_BOUNDARY(wd,TOP)) / 2. + call wl_axis_on_line (xcen, ycen, pole_position[X_DIM], + pole_position[Y_DIM], WL_SCREEN_BOUNDARY(wd,1), nx, ny) + + if (IS_INDEFD(nx) || IS_INDEFD(ny)) { + WL_BAD_LABEL_SIDE(wd) = BOTTOM + WL_POLAR_LABEL_DIRECTION(wd) = LEFT + } else { + WL_BAD_LABEL_SIDE(wd) = wl_find_side (nx, ny, + WL_SCREEN_BOUNDARY(wd,1)) + if (WL_BAD_LABEL_SIDE(wd) == LEFT || WL_BAD_LABEL_SIDE(wd) == + RIGHT) + if (abs (ny - WL_SCREEN_BOUNDARY(wd,BOTTOM)) < + abs (ny - WL_SCREEN_BOUNDARY(wd,TOP))) + WL_POLAR_LABEL_DIRECTION(wd) = BOTTOM + else + WL_POLAR_LABEL_DIRECTION(wd) = TOP + else + if (abs (nx - WL_SCREEN_BOUNDARY(wd,LEFT)) < + abs (nx - WL_SCREEN_BOUNDARY(wd,RIGHT))) + WL_POLAR_LABEL_DIRECTION(wd) = LEFT + else + WL_POLAR_LABEL_DIRECTION(wd) = RIGHT + } + + } +end + + +# WL_COORD_ROTATION -- Determine "rotation" between the coordinate systems. +# +# Description +# This routine takes the world-to-logical coordinate transformation and +# two points in the world system which should define the positive verticle +# axis in the world system. These points are translated into the logical +# system and the angle between the logical vector and its positive verticle +# vector is calculated and returned. The rotation angle is returned +# in degrees and is always positive. + +double procedure wl_coord_rotation (wlct, flip, wx1, wy1, wx2, wy2) + +pointer wlct # I: the world-to-logical transformation +int flip # I: true if the coordinates are transposed +double wx1, wy1, wx2, wy2 # I: points in world space to figure rotation from + +double delx, dely, rota, x1, y1, x2, y2 +bool fp_equald() + +begin + # Transform the points to the logical system. + call wl_w2ld (wlct, flip, wx1, wy1, x1, y1, 1) + call wl_w2ld (wlct, flip, wx2, wy2, x2, y2, 1) + + # Determine the rotation. + delx = x2 - x1 + dely = y2 - y1 + if (fp_equald (delx, 0.0D0) && fp_equald (dely, 0.0D0)) + rota = 0. + else + rota = RADTODEG (atan2 (dely, delx)) + + if (rota < 0.0D0) + rota = rota + FULL_CIRCLE + + return (rota) +end + + +# Define how many axis one should go for. + +define RA_NUM_TRY 6 +define DEC_NUM_TRY 6 +define DEC_POLAR_NUM_TRY 4 + +# WL_ROUND_AXIS - Round values for the axis. + +procedure wl_round_axis (wd, axis, minimum, maximum, range) + +pointer wd # I: the WCSLAB descriptor +int axis # I: the axis being worked on +double minimum, maximum, range # I: raw values to be rounded + +int num_try + +begin + # Depending on axis type, round the values. + switch (WL_SYSTEM_TYPE(wd)) { + case RA_DEC: + if (axis == LONGITUDE) + call wl_round_ra (minimum, maximum, range, RA_NUM_TRY, + WL_BEGIN(wd,LONGITUDE), WL_END(wd,LONGITUDE), + WL_MAJOR_INTERVAL(wd,LONGITUDE)) + else { + if (WL_GRAPH_TYPE(wd) == POLAR) + num_try = DEC_POLAR_NUM_TRY + else + num_try = DEC_NUM_TRY + call wl_round_dec (minimum, maximum, range, num_try, + WL_BEGIN(wd,LATITUDE), WL_END(wd,LATITUDE), + WL_MAJOR_INTERVAL(wd,LATITUDE)) + } + + default: + call wl_generic_round (minimum, maximum, range, WL_BEGIN(wd,axis), + WL_END(wd,axis), WL_MAJOR_INTERVAL(wd,axis)) + } + +end + + +# WL_GET_AXIS2_LABEL_DIRECTION -- Dertermine label direction for latitides. +# +# Description +# Determine from which edge of the graph the axis 2 labels are to +# appear. This (in general) is the opposite edge from which the pole +# is nearest to. Move the pole to the closest edges, determine which +# side it is, then chose the direction as the opposite. Also determines +# the Axis 1 at which the Axis 2 labels will appear. + +procedure wl_get_axis2_label_direction (lwct, flip, pole_position, + screen_boundary, pole_label_position, bad_label_side) + +pointer lwct # I: logical-to-world transformation +int flip # I: true if the axis are transposed +double pole_position[N_DIM] # I: the position of the pole +double screen_boundary[N_SIDES] # I: the edges of the screen +double pole_label_position # O: the axis 1 that axis 2 labels should + # appear for polar|near-polar graphs +int bad_label_side # O: side not to place axis 1 labels + +double dif, tdif, dummy + +begin + # Determine which direction, up or down, the axis 2's will be labelled. + dif = abs (screen_boundary[TOP] - pole_position[AXIS2]) + bad_label_side= TOP + tdif = abs (screen_boundary[BOTTOM] - pole_position[AXIS2]) + if (tdif < dif) { + dif = tdif + bad_label_side = BOTTOM + } + + # Determine at what value of Axis 1 the Axis 2 labels should appear. + switch (bad_label_side) { + case TOP: + call wl_l2wd (lwct, flip, pole_position[AXIS1], + screen_boundary[BOTTOM], pole_label_position, dummy, 1) + case BOTTOM: + call wl_l2wd (lwct, flip, pole_position[AXIS1], + screen_boundary[TOP], pole_label_position, dummy, 1) + case LEFT: + call wl_l2wd (lwct, flip, screen_boundary[RIGHT], + pole_position[AXIS2], pole_label_position, dummy, 1) + case RIGHT: + call wl_l2wd (lwct, flip, screen_boundary[LEFT], + pole_position[AXIS2], pole_label_position, dummy, 1) + } + +end + + +# WL_DIRECTION_FROM_AXIS1 -- Determine axis 2 label direction from axis 1. +# +# Function Returns +# This returns the side where Axis 1 should not be labelled. + +int procedure wl_direction_from_axis1 (wlct, flip, pole_position, north, + polar_label_position, lbegin, lend, screen_boundary) + +pointer wlct # I: world-to-logical transformation +int flip # I: true if the axes are transposed +double pole_position[N_DIM] # I: the pole position +bool north # I: true if the pole is the north pole +double polar_label_position # I: the axis 1 where axis 2 will be + # marked +double lbegin # I: low end of axis 2 +double lend # I: high end of axis 2 +double screen_boundary[N_SIDES] # I: the window boundary + +double nx, ny, cx, cy +int wl_find_side() + +begin + # Determine the point in logical space where the axis 1 and the + # minimum axis 2 meet. + + if (north) + call wl_w2ld (wlct, flip, polar_label_position, lbegin, nx, ny, 1) + else + call wl_w2ld (wlct, flip, polar_label_position, lend, nx, ny, 1) + + # This line should cross a window boundary. Find that point. + + call wl_axis_on_line (pole_position[X_DIM], pole_position[Y_DIM], + screen_boundary, nx, ny, cx, cy) + + # Get the side that the crossing point is. This is the axis 2 labelling + # direction. + + if (IS_INDEFD(cx) || IS_INDEFD(cy)) + return (INDEFI) + else + return (wl_find_side (cx, cy, screen_boundary)) +end + + +# WL_OPPOSITE_SIDE - Return the opposite of the given side. +# +# Returns +# The opposite side of the specified side as follows: +# RIGHT -> LEFT +# LEFT -> RIGHT +# TOP -> BOTTOM +# BOTTOM -> TOP + +int procedure wl_opposite_side (side) + +int side # I: the side to find the opposite of + +int new_side + +begin + switch (side) { + case LEFT: + new_side = RIGHT + case RIGHT: + new_side = LEFT + case TOP: + new_side = BOTTOM + case BOTTOM: + new_side = TOP + } + + return (new_side) +end + + +# Define whether things are on the screen boundary or on them. + +define IN (($1>=screen_boundary[LEFT])&&($1<=screen_boundary[RIGHT])&&($2>=screen_boundary[BOTTOM])&&($2<=screen_boundary[TOP])) + + +# WL_AXIS_ON_LINE - Determine intersection of line and a screen boundary. +# +# Description +# Return the point where the line defined by the two input points +# crosses a screen boundary. The boundary is choosen by determining +# which one is between the two points. + +procedure wl_axis_on_line (x0, y0, x1, y1, screen_boundary, nx, ny) + +double x0, y0, x1, y1 # I: random points in space +double screen_boundary[N_SIDES] # I: sides of the window +double nx, ny # O: the closest point on a window boundary + +double x_val[N_SIDES], y_val[N_SIDES], tx0, ty0, tx1, ty1, w[2] +int i +pointer cvx, cvy +double dcveval() + +begin + # Get the line parameters. + x_val[1] = x0 + x_val[2] = x1 + y_val[1] = y0 + y_val[2] = y1 + + iferr (call dcvinit (cvx, CHEBYSHEV, 2, min (x0, x1), max (x0, x1))) + cvx = NULL + else { + call dcvfit (cvx, x_val, y_val, w, 2, WTS_UNIFORM, i) + if (i != OK) + call error (i, "wlaxie: Error solving on X") + } + + iferr (call dcvinit (cvy, CHEBYSHEV, 2, min (y0, y1), max (y0, y1))) + cvy = NULL + else { + call dcvfit (cvy, y_val, x_val, w, 2, WTS_UNIFORM, i) + if (i != OK) + call error (i, "wlaxie: Error solving on Y") + } + + # Solve for each side. + x_val[LEFT] = screen_boundary[LEFT] + if (cvx == NULL) + y_val[LEFT] = screen_boundary[LEFT] + else + y_val[LEFT] = dcveval (cvx, x_val[LEFT]) + + x_val[RIGHT] = screen_boundary[RIGHT] + if (cvx == NULL ) + y_val[RIGHT] = screen_boundary[RIGHT] + else + y_val[RIGHT] = dcveval (cvx, x_val[RIGHT]) + + y_val[TOP] = screen_boundary[TOP] + if (cvy == NULL) + x_val[TOP] = screen_boundary[TOP] + else + x_val[TOP] = dcveval (cvy, y_val[TOP]) + + y_val[BOTTOM] = screen_boundary[BOTTOM] + if (cvy == NULL) + x_val[BOTTOM] = screen_boundary[BOTTOM] + else + x_val[BOTTOM] = dcveval (cvy, y_val[BOTTOM]) + + # Rearrange the input points to be in ascending order. + if (x0 < x1) { + tx0 = x0 + tx1 = x1 + } else { + tx0 = x1 + tx1 = x0 + } + + if (y0 < y1) { + ty0 = y0 + ty1 = y1 + } else { + ty0 = y1 + ty1 = y0 + } + + # Now find which point is between the two given points and is within + # the viewing area. + # NOTE: Conversion to real for the check- if two points are so close + # for double, any of them would serve as the correct answer. + + nx = INDEFD + ny = INDEFD + for (i = 1; i <= N_SIDES; i = i + 1) + if (real (tx0) <= real (x_val[i]) && + real (x_val[i]) <= real (tx1) && + real (ty0) <= real (y_val[i]) && + real (y_val[i]) <= real (ty1) && + IN (x_val[i], y_val[i]) ) { + nx = x_val[i] + ny = y_val[i] + } + + # Release the curve fit descriptors. + if (cvx != NULL) + call dcvfree (cvx) + if (cvy != NULL) + call dcvfree (cvy) +end + + +# WL_FIND_SIDE -- Return the side that the given point is lying on. +# +# Function Returns +# Return the side, TOP, BOTTOM, LEFT, or RIGHT, that the specified +# point is lying on. One of the coordinates must be VERY CLOSE to one of +# the sides or INDEFI will be returned. + +int procedure wl_find_side (x, y, screen_boundary) + +double x, y # I: the point to inquire about +double screen_boundary[N_SIDES] # I: the edges of the screen + +double dif, ndif +int side + +begin + dif = abs (x - screen_boundary[LEFT]) + side = LEFT + + ndif = abs (x - screen_boundary[RIGHT]) + if (ndif < dif) { + side = RIGHT + dif = ndif + } + + ndif = abs (y - screen_boundary[BOTTOM]) + if (ndif < dif) { + side = BOTTOM + dif = ndif + } + + ndif = abs (y - screen_boundary[TOP]) + if (ndif < dif) + side = TOP + + return (side) +end + + +# WL_RA_RANGE -- Determine the range in RA given a list of possible values. +# +# Description +# Determine the largest range in RA from the provided list of values. +# The problem here is that it is unknown which way the graph is oriented. +# To simplify the problem, it is assume that the graph range does not extend +# beyond a hemisphere and that all distances in RA is less than a hemisphere. +# This assumption is needed to decide when the 0 hour is on the graph. + +procedure wl_ra_range (ra, n_values, min, max, diff) + +double ra[ARB] # I: the possible RA values +int n_values # I: the number of possible RA values +double min # I/O: the minimum RA +double max # I/O: the maximum RA +double diff # I/O: the difference between minimum and maximum + +bool wrap +int i, j, n_diffs +pointer sp, max_array, min_array, ran_array +int wl_max_element_array() + +begin + call smark (sp) + call salloc (max_array, n_values * n_values, TY_DOUBLE) + call salloc (min_array, n_values * n_values, TY_DOUBLE) + call salloc (ran_array, n_values * n_values, TY_DOUBLE) + + # Check whether the RA is wrapped or not. + n_diffs = 0 + do i = 1, n_values { + if (ra[i] >= min && ra[i] <= max) + next + n_diffs = n_diffs + 1 + } + if (n_diffs > 0) + wrap = true + else + wrap = false + + n_diffs = 0 + for (i = 1; i <= n_values; i = i + 1) { + for (j = i + 1; j <= n_values; j = j + 1) { + n_diffs = n_diffs + 1 + call wl_getradif (ra[i], ra[j], Memd[min_array+n_diffs-1], + Memd[max_array+n_diffs-1], Memd[ran_array+n_diffs-1], + wrap) + } + } + + i = wl_max_element_array (Memd[ran_array], n_diffs) + min = Memd[min_array+i-1] + max = Memd[max_array+i-1] + diff = Memd[ran_array+i-1] + + call sfree (sp) +end + + +# WL_GETRADIFF -- Get differences in RA based on degrees. +# +# Description +# This procedure determines, given two values in degrees, the minimum, +# maximum, and difference of those values. The assumption is that no +# difference should be greater than half a circle. Based on this assumption, +# a difference is found and the minimum and maximum are determined. The +# maximum can be greater than 360 degrees. + +procedure wl_getradif (val1, val2, min, max, diff, wrap) + +double val1, val2 # I: the RA values +double min, max # O: the min RA and max RA (possibly > 360.0) +double diff # O: the min, max difference +bool wrap # I: is the ra wrapped ? + +begin + if (! wrap && (abs (val1 - val2) > HALF_CIRCLE)) + if (val1 < val2) { + min = val2 + max = val1 + FULL_CIRCLE + } else { + min = val1 + max = val2 + FULL_CIRCLE + } + else + if (val1 < val2) { + min = val1 + max = val2 + } else { + min = val2 + max = val1 + } + diff = max - min +end + + +define NRAGAP 26 + +# WL_ROUND_RA -- Modify the RA limits and calculate an interval to label. +# +# Description +# The RA limits determine by just the extremes of the window ususally do +# not fall on "reasonable" boundaries; i.e. essentially they are random +# numbers. However, for labelling purposes, it is nice to have grids and +# tick marks for "rounded" numbers- For RA, this means values close to +# whole hours, minutes, or seconds. For example, if the span across the +# plot is a few hours, the marks and labels should represent simply whole +# hours. This routine determines new RA limits based on this and some +# interval to produce marks between the newly revised limits. + +procedure wl_round_ra (longmin, longmax, longran, num_try, minimum, maximum, + major_interval) + +double longmin # I: longitude minimum +double longmax # I: longitude maximum +double longran # I: longitude range +int num_try # I: the number of intervals to try for +double minimum # O: the minimum RA value (in degrees) +double maximum # O: the maximum RA value (in degrees) +double major_interval # O: the appropriate interval (in degrees) for the + # major line marks. + +double ragap[NRAGAP] +double wl_check_arrayd(), wl_round_upd() +data ragap / 1.0D-4, 2.0D-4, 5.0D-4, 1.0D-3, 2.0D-3, 5.0D-3, + 0.01D0, 0.02D0, 0.05D0, 0.1D0, 0.2D0, 0.5D0, 1.0D0, + 2.0D0, 5.0D0, 10.0D0, 20.0D0, 30.0D0, 60.0D0, 120.0D0, + 300.0D0, 600.0D0, 1.2D3, 1.8D3, 3.6D3, 7.2D3 / + + +begin + major_interval = wl_check_arrayd (DEGTOST (longran) / num_try, + ragap, NRAGAP) + minimum = STTODEG (wl_round_upd (DEGTOST (longmin), major_interval) - + major_interval) + maximum = STTODEG (wl_round_upd (DEGTOST (longmax), major_interval)) + major_interval = STTODEG (major_interval) +end + + +define NDECGAP 28 + +# WL_ROUND_DEC -- Modify the DEC limits and calculate an interval to label. +# +# Description +# The DEC limits determine by just the extremes of the window ususally do +# not fall on "reasonable" boundaries; i.e. essentially they are random +# numbers. However, for labelling purposes, it is nice to have grids and +# tick marks for "rounded" numbers- For DEC, this means values close to +# whole degrees, minutes, or seconds. For example, if the span across the +# plot is a few degrees, the marks and labels should represent simply whole +# degrees. This routine determines new DEC limits based on this and some +# interval to produce marks between the newly revised limits. + +procedure wl_round_dec (latmin, latmax, latran, num_try, minimum, maximum, + major_interval) + +double latmin # I: the latitude minimum +double latmax # I: the latitude maximum +double latran # I: the latitude range +int num_try # I: number of intervals to try for +double minimum # O: the DEC minimum +double maximum # O: the DEC maximum +double major_interval # O: the labelling interval to use for major lines + +double decgap[NDECGAP] +double wl_check_arrayd(), wl_round_upd() +data decgap / 1.0D-4, 2.0D-4, 5.0D-4, 1.0D-3, 2.0D-3, 5.0D-3, + 0.01D0, 0.02D0, 0.05D0, 0.1D0, 0.2D0, 0.5D0, 1.0D0, + 2.0D0, 5.0D0, 10.0D0,20.0D0, 30.0D0, 60.0D0, 120.0d0, + 300.0D0, 600.0D0, 1.2D3, 1.8D3, 3.6D3, 7.2D3, 1.8D4, 3.6D4 / + +begin + major_interval = wl_check_arrayd (DEGTOSA (latran) / num_try, + decgap, NDECGAP) + minimum = SATODEG (wl_round_upd (DEGTOSA (latmin), major_interval) - + major_interval) + maximum = SATODEG (wl_round_upd (DEGTOSA (latmax), major_interval)) + major_interval = SATODEG (major_interval) + + # Make sure that the grid marking does not include the pole. + maximum = min (maximum, NORTH_POLE_LATITUDE - major_interval) + minimum = max (minimum, SOUTH_POLE_LATITUDE + major_interval) +end + + +# WL_GENERIC_ROUND -- Round the values (if possible). +# +# History +# 7Feb91 - Created by Jonathan D. Eisenhamer, STScI. + +procedure wl_generic_round (minimum, maximum, range, lbegin, lend, interval) + +double minimum, maximum, range # I: the raw input values +double lbegin, lend # O: the begin and end label points +double interval # O: the major label interval + +double amant, diff +int iexp, num +double wl_round_upd() + +begin + diff = log10 (abs (range) / 4.D0) + iexp = int (diff) + if (diff < 0) + iexp = iexp - 1 + + amant = diff - double (iexp) + if (amant < 0.15D0) + num = 1 + else if (amant < 0.50D0) + num = 2 + else if (amant < 0.85D0) + num = 5 + else + num = 10 + + interval = double (num) * 10.0D0 ** iexp + lbegin = wl_round_upd (minimum, interval) - interval + lend = wl_round_upd (maximum, interval) +end + + +# WL_ROUND_UPD -- Round X up to nearest whole multiple of Y. + +double procedure wl_round_upd (x, y) + +double x # I: value to be rounded +double y # I: multiple of X is to be rounded up in + +double z, r + +begin + if (x < 0.0D0) + z = 0.0D0 + else + z = y + r = y * double (int ((x + z) / y)) + + return (r) +end + + + +# WL_CHECK_ARRAYD -- Check proximity of array elements to each other. +# +# Description +# Returns the element of the array arr(n) which is closest to an exact +# value EX. + +double procedure wl_check_arrayd (ex, arr, n) + +double ex # I: the exact value +double arr[ARB] # I: the array of rounded values +int n # I: dimension of array of rounded values + +int j + +begin + for (j = 1; j < n && (ex - arr[j]) > 0.0D0; j = j + 1) + ; + if (j > 1 && j < n) + if (abs (ex - arr[j-1]) < abs (ex - arr[j])) + j = j - 1 + + return (arr[j]) +end diff --git a/pkg/utilities/nttools/stxtools/wcslab/wlutil.x b/pkg/utilities/nttools/stxtools/wcslab/wlutil.x new file mode 100644 index 00000000..c79b8f5e --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/wlutil.x @@ -0,0 +1,390 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imio.h> +include <imhdr.h> +include <gset.h> +include <math.h> + +# WL_IMD_VIEWPORT -- Map the viewport and window of the image display. + +procedure wl_imd_viewport (frame, im, c1, c2, l1, l2, vl, vr, vb, vt) + +int frame # I: display frame to be overlayed +pointer im # I: pointer to the input image +real c1, c2, l1, l2 # I/O: input/output window +real vl, vr, vb, vt # I/O: input/output viewport + +int wcs_status, dim1, dim2, step1, step2 +pointer sp, frimage, frim, iw +real x1, x2, y1, y2, fx1, fx2, fy1, fy2, junkx, junky +real vx1, vx2, vy1, vy2, nx1, nx2, ny1, ny2 +pointer imd_mapframe(), iw_open() + + +begin + # If all of the viewport parameters were defined by the user + # use the default viewport and window. + if (! IS_INDEFR(vl) && ! IS_INDEFR(vr) && ! IS_INDEFR(vb) && + ! IS_INDEFR(vt)) + return + + # Allocate some memory. + call smark (sp) + call salloc (frimage, SZ_FNAME, TY_CHAR) + + # Open the requested display frame and get the loaded image name. + # If this name is blank, use the default viewport and window. + + frim = imd_mapframe (frame, READ_ONLY, YES) + iw = iw_open (frim, frame, Memc[frimage], SZ_FNAME, wcs_status) + if (Memc[frimage] == EOS || wcs_status == ERR) { + call iw_close (iw) + call imunmap (frim) + call sfree (sp) + return + } + + # Find the beginning and end points of the requested image section. + # We already know at this point that the input logical image is + # 2-dimensional. However this 2-dimensional section may be part of + # n-dimensional image. + + # X dimension. + dim1 = IM_VMAP(im,1) + step1 = IM_VSTEP(im,1) + if (step1 >= 0) { + x1 = IM_VOFF(im,dim1) + 1 + x2 = x1 + IM_LEN(im,1) - 1 + } else { + x1 = IM_VOFF(im,dim1) - 1 + x2 = x1 - IM_LEN(im,1) + 1 + } + + # Y dimension. + dim2 = IM_VMAP(im,2) + step2 = IM_VSTEP(im,2) + if (step2 >= 0) { + y1 = IM_VOFF(im,dim2) + 1 + y2 = y1 + IM_LEN(im,2) - 1 + } else { + y1 = IM_VOFF(im,dim2) - 1 + y2 = y1 - IM_LEN(im,2) + 1 + } + + # Get the frame buffer coordinates corresponding to the lower left + # and upper right corners of the image section. + + call iw_im2fb (iw, x1, y1, fx1, fy1) + call iw_im2fb (iw, x2, y2, fx2, fy2) + if (fx1 > fx2) { + junkx = fx1 + fx1 = fx2 + fx2 = junkx + } + if (fy1 > fy2) { + junky = fy1 + fy1 = fy2 + fy2 = junky + } + + # Check that some portion of the input image is in the display. + # If not select the default viewport and window coordinates. + if (fx1 > IM_LEN(frim,1) || fx2 < 1.0 || fy1 > IM_LEN(frim,2) || + fy2 < 1.0) { + call iw_close (iw) + call imunmap (frim) + call sfree (sp) + return + } + + # Compute a new viewport and window for X. + if (fx1 >= 1.0) { + vx1 = max (0.0, min (1.0, (fx1 - 0.5) / IM_LEN(frim,1))) + nx1 = 1.0 + } else { + vx1 = 0.0 + call iw_fb2im (iw, 1.0, 1.0, junkx, junky) + if (step1 >= 0) + nx1 = max (1.0, junkx - x1 + 1.0) + else + nx2 = max (1.0, junkx - x2 + 1.0) + } + if (fx2 <= IM_LEN(frim,1)) { + vx2 = max (0.0, min (1.0, (fx2 + 0.5) / IM_LEN(frim,1))) + nx2 = IM_LEN(im,1) + } else { + vx2 = 1.0 + call iw_fb2im (iw, real(IM_LEN(frim,1)), real (IM_LEN(frim,2)), + junkx, junky) + if (step1 >= 0) + nx2 = min (real (IM_LEN(im,1)), junkx - x1 + 1.0) + else + nx1 = min (real (IM_LEN(im,1)), junkx - x2 + 1.0) + } + + # Compute a new viewport and window for Y. + if (fy1 >= 1.0) { + vy1 = max (0.0, min (1.0, (fy1 - 0.5) / IM_LEN(frim,2))) + ny1 = 1.0 + } else { + vy1 = 0.0 + call iw_fb2im (iw, 1.0, 1.0, junkx, junky) + if (step2 >= 0) + ny1 = max (1.0, junky - y1 + 1) + else + ny2 = max (1.0, junky - y2 + 1) + } + if (fy2 <= IM_LEN(frim,2)) { + vy2 = max (0.0, min (1.0, (fy2 + 0.5) / IM_LEN(frim,2))) + ny2 = IM_LEN(im,2) + } else { + vy2 = 1.0 + call iw_fb2im (iw, real (IM_LEN(frim,1)), real (IM_LEN(frim,2)), + junkx, junky) + if (step2 >= 0) + ny2 = min (real (IM_LEN(im,2)), junky - y1 + 1.0) + else + ny1 = min (real (IM_LEN(im,2)), junky - y2 + 1.0) + } + + # Define a the new viewport and window. + if (IS_INDEFR(vl)) { + vl = vx1 + c1 = nx1 + } + if (IS_INDEFR(vr)) { + vr = vx2 + c2 = nx2 + } + if (IS_INDEFR(vb)) { + vb = vy1 + l1 = ny1 + } + if (IS_INDEFR(vt)) { + vt = vy2 + l2 = ny2 + } + + # Clean up. + call iw_close (iw) + call imunmap (frim) + call sfree (sp) +end + + +define EDGE1 0.1 +define EDGE2 0.9 +define EDGE3 0.12 +define EDGE4 0.92 + +# WL_MAP_VIEWPORT -- Set device viewport wcslab plots. If not specified by +# user, a default viewport centered on the device is used. + +procedure wl_map_viewport (gp, c1, c2, l1, l2, ux1, ux2, uy1, uy2, fill) + +pointer gp # I: pointer to graphics descriptor +real c1, c2, l1, l2 # I: the column and line limits +real ux1, ux2, uy1, uy2 # I/O: NDC coordinates of requested viewort +bool fill # I: fill viewport (vs preserve aspect ratio) + +int ncols, nlines +real xcen, ycen, ncolsr, nlinesr, ratio, aspect_ratio +real x1, x2, y1, y2, ext, xdis, ydis +bool fp_equalr() +real ggetr() +data ext /0.0625/ + +begin + ncols = nint (c2 - c1) + 1 + ncolsr = real (ncols) + nlines = nint (l2 - l1) + 1 + nlinesr = real (nlines) + + # Determine the standard window sizes. + if (fill) { + x1 = 0.0; x2 = 1.0 + y1 = 0.0; y2 = 1.0 + } else { + x1 = EDGE1; x2 = EDGE2 + y1 = EDGE3; y2 = EDGE4 + } + + # If any values were specified, then replace them here. + if (! IS_INDEFR(ux1)) + x1 = ux1 + if (! IS_INDEFR(ux2)) + x2 = ux2 + if (! IS_INDEFR(uy1)) + y1 = uy1 + if (! IS_INDEFR(uy2)) + y2 = uy2 + + # Calculate optimum viewport, as in NCAR's conrec, hafton. + if (! fill) { + ratio = min (ncolsr, nlinesr) / max (ncolsr, nlinesr) + if (ratio >= ext) { + if (ncols > nlines) + y2 = (y2 - y1) * nlinesr / ncolsr + y1 + else + x2 = (x2 - x1) * ncolsr / nlinesr + x1 + } + } + + xdis = x2 - x1 + ydis = y2 - y1 + xcen = (x2 + x1) / 2. + ycen = (y2 + y1) / 2. + + # So far, the viewport has been calculated so that equal numbers of + # image pixels map to equal distances in NDC space, regardless of + # the aspect ratio of the device. If the parameter "fill" has been + # set to no, the user wants to compensate for a non-unity aspect + # ratio and make equal numbers of image pixels map to into the same + # physical distance on the device, not the same NDC distance. + + if (! fill) { + aspect_ratio = ggetr (gp, "ar") + if (fp_equalr (aspect_ratio, 0.0)) + aspect_ratio = 1.0 + + if (aspect_ratio < 1.0) + # Landscape + xdis = xdis * aspect_ratio + else if (aspect_ratio > 1.0) + # Portrait + ydis = ydis / aspect_ratio + } + + ux1 = xcen - (xdis / 2.0) + ux2 = xcen + (xdis / 2.0) + uy1 = ycen - (ydis / 2.0) + uy2 = ycen + (ydis / 2.0) + + call gsview (gp, ux1, ux2, uy1, uy2) + call gswind (gp, c1, c2, l1, l2) +end + + +# WL_W2LD -- Transform world coordinates to logical coordinates. + +procedure wl_w2ld (wlct, flip, wx, wy, lx, ly, npts) + +pointer wlct # I: the MWCS coordinate transformation descriptor +int flip # I: true if the axes are transposed +double wx[npts], wy[npts] # I: the world coordinates +double lx[npts], ly[npts] # O: the logical coordinates +int npts # I: the number of points to translate + +begin + if (flip == YES) + call mw_v2trand (wlct, wx, wy, ly, lx, npts) + else + call mw_v2trand (wlct, wx, wy, lx, ly, npts) +end + + +# WL_L2WD -- Transform logical coordinates to world coordinates. + +procedure wl_l2wd (lwct, flip, lx, ly, wx, wy, npts) + +pointer lwct # I: the MWCS coordinate transformation descriptor +int flip # I: true if the axes are transposed +double lx[npts], ly[npts] # I: the logical coordinates +double wx[npts], wy[npts] # O: the world coordinates +int npts # I: the number of points to translate + +begin + if (flip == YES) + call mw_v2trand (lwct, ly, lx, wx, wy, npts) + else + call mw_v2trand (lwct, lx, ly, wx, wy, npts) +end + + +# WL_MAX_ELEMENT_ARRAY -- Return the index of the maximum array element. +# +# Description +# This function returns the index of the maximum value of the input array. + +int procedure wl_max_element_array (array, npts) + +double array[ARB] # I: the array to look through for the maximum +int npts # I: the number of points in the array + +int i, maximum + +begin + maximum = 1 + for (i = 2; i <= npts; i = i + 1) + if (array[i] > array[maximum]) + maximum = i + + return (maximum) +end + + +# WL_DISTANCED - Determine the distance between two points. + +double procedure wl_distanced (x1, y1, x2, y2) + +double x1, y1 # I: coordinates of point 1 +double x2, y2 # I: coordinates of point 2 + +double a, b + +begin + a = x1 - x2 + b = y1 - y2 + return (sqrt ((a * a) + (b * b))) +end + + +# WL_DISTANCER -- Determine the distance between two points. + +real procedure wl_distancer (x1, y1, x2, y2) + +real x1, y1 # I: coordinates of point 1 +real x2, y2 # I: coordinates of point 2 + +real a, b + +begin + a = x1 - x2 + b = y1 - y2 + return (sqrt ((a * a) + (b * b))) +end + + +# The dimensionality. +define N_DIM 2 + +# Define some memory management. +define ONER Memr[$1+$2-1] + +# WL_ROTATE -- Rotate a vector. + +procedure wl_rotate (x, y, npts, angle, nx, ny) + +real x[npts], y[npts] # I: the vectors to rotate +int npts # I: the number of points in the vectors +real angle # I: the angle to rotate (radians) +real nx[npts], ny[npts] # O: the transformed vectors + +pointer sp, center, mw +pointer mw_open(), mw_sctran() + +begin + # Get some memory. + call smark (sp) + call salloc (center, N_DIM, TY_REAL) + + mw = mw_open (NULL, N_DIM) + ONER(center,1) = 0. + ONER(center,2) = 0. + call mw_rotate (mw, -DEGTORAD( angle ), ONER(center,1), 3b) + call mw_v2tranr (mw_sctran (mw, "physical", "logical", 3b), + x, y, nx, ny, npts) + + call mw_close (mw) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/wcslab/wlwcslab.x b/pkg/utilities/nttools/stxtools/wcslab/wlwcslab.x new file mode 100644 index 00000000..156c9a8a --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/wlwcslab.x @@ -0,0 +1,181 @@ +include <gio.h> +include <gset.h> +include "wcslab.h" +include "wcs_desc.h" + +# Define the memory structure for saving the graphics wcs. +define SAVE_BLOCK_SIZE 16 +define OLD_NDC_VIEW Memr[wcs_save_block-1+$1] +define OLD_NDC_WIND Memr[wcs_save_block+3+$1] +define OLD_PLT_VIEW Memr[wcs_save_block+7+$1] +define OLD_PLT_WIND Memr[wcs_save_block+11+$1] + +# WL_WCSLAB -- Label using a defined wcs. +# +# Description +# This routine uses the information in the WCSLAB descriptor to perform +# labelling. +# +# Before this routine can be called, several things must have already +# occured. They are as follows: +# 1 A call to wl_create must be made to create the WCSLAB descriptor. +# 2 The WCS_MW component must be set to the MWCS object of the +# desired transformations. +# 3 A call to wl_get_system_type must be made. +# 4 The graphics device must have been opened and the window defined. +# The WCS_GP component of the WCSLAB descriptor must be set to the +# graphics window descriptor. +# +# When done with this routine, the WL_GP and WL_MW components must be +# deallocated seperately. Then only wlab_destroy need be called to +# remove the WCSLAB descriptor. +# +#--------------------------------------------------------------------------- + +procedure wl_wcslab (wd) + +pointer wd # I: the WCSLAB descriptor + +int old_clip, old_pltype, old_txquality, old_wcs +pointer sp, wcs_save_block +real old_plwidth, old_txsize, old_txup +int gstati() +real gstatr() + +begin + # Allocate working space. + call smark(sp) + call salloc(wcs_save_block, SAVE_BLOCK_SIZE, TY_STRUCT) + + # Store certain graphics parameters. + old_plwidth = gstatr (WL_GP(wd), G_PLWIDTH) + old_txsize = gstatr (WL_GP(wd), G_TXSIZE) + old_txup = gstatr (WL_GP(wd), G_TXUP) + old_clip = gstati (WL_GP(wd), G_CLIP) + old_pltype = gstati (WL_GP(wd), G_PLTYPE) + old_txquality= gstati (WL_GP(wd), G_TXQUALITY) + old_wcs = gstati (WL_GP(wd), G_WCS) + + # Choose two other graphics wcs' for internal use. Save the wcs for + # later restoration. + if( old_wcs < MAX_WCS - 2 ) { + WL_NDC_WCS(wd) = old_wcs + 1 + WL_PLOT_WCS(wd) = WL_NDC_WCS(wd) + 1 + } else { + WL_NDC_WCS(wd) = old_wcs - 1 + WL_PLOT_WCS(wd) = WL_NDC_WCS(wd) - 1 + } + call gseti(WL_GP(wd), G_WCS, WL_NDC_WCS(wd)) + call ggview(WL_GP(wd), OLD_NDC_VIEW(LEFT), OLD_NDC_VIEW(RIGHT), + OLD_NDC_VIEW(BOTTOM), OLD_NDC_VIEW(TOP)) + call ggwind(WL_GP(wd), OLD_NDC_WIND(LEFT), OLD_NDC_WIND(RIGHT), + OLD_NDC_WIND(BOTTOM), OLD_NDC_WIND(TOP)) + call gseti(WL_GP(wd), G_WCS, WL_PLOT_WCS(wd)) + call ggview(WL_GP(wd), OLD_PLT_VIEW(LEFT), OLD_PLT_VIEW(RIGHT), + OLD_PLT_VIEW(BOTTOM), OLD_PLT_VIEW(TOP)) + call ggwind(WL_GP(wd), OLD_PLT_WIND(LEFT), OLD_PLT_WIND(RIGHT), + OLD_PLT_WIND(BOTTOM), OLD_PLT_WIND(TOP)) + + # Set the graphics device the way wcslab requires it. + call gseti (WL_GP(wd), G_WCS, old_wcs) + call wl_graphics (wd) + + # Determine basic characteristics of the plot. + call wl_setup (wd) + + # Plot the grid lines. + call wl_grid (wd) + + # Put the grid labels on the lines. + if (WL_LABON(wd) == YES) + call wl_label (wd) + + # Restore the original graphics wcs. + call gseti(WL_GP(wd), G_WCS, WL_NDC_WCS(wd)) + call gsview(WL_GP(wd), OLD_NDC_VIEW(LEFT), OLD_NDC_VIEW(RIGHT), + OLD_NDC_VIEW(BOTTOM), OLD_NDC_VIEW(TOP)) + call gswind(WL_GP(wd), OLD_NDC_WIND(LEFT), OLD_NDC_WIND(RIGHT), + OLD_NDC_WIND(BOTTOM), OLD_NDC_WIND(TOP)) + call gseti(WL_GP(wd), G_WCS, WL_PLOT_WCS(wd)) + call gsview(WL_GP(wd), OLD_PLT_VIEW(LEFT), OLD_PLT_VIEW(RIGHT), + OLD_PLT_VIEW(BOTTOM), OLD_PLT_VIEW(TOP)) + call gswind(WL_GP(wd), OLD_PLT_WIND(LEFT), OLD_PLT_WIND(RIGHT), + OLD_PLT_WIND(BOTTOM), OLD_PLT_WIND(TOP)) + + # Restore original graphics state. + call gsetr (WL_GP(wd), G_PLWIDTH, old_plwidth) + call gsetr (WL_GP(wd), G_TXSIZE, old_txsize) + call gsetr (WL_GP(wd), G_TXUP, old_txup) + call gseti (WL_GP(wd), G_CLIP, old_clip) + call gseti (WL_GP(wd), G_PLTYPE, old_pltype) + call gseti (WL_GP(wd), G_TXQUALITY, old_txquality) + call gseti (WL_GP(wd), G_WCS, old_wcs) + + call sfree (sp) +end + + +# WL_GRAPHICS -- Setup the graphics device appropriate for the occasion. + +procedure wl_graphics (wd) + +pointer wd # I: the WCSLAB descriptor + +real relative_size, vl, vr, vb, vt +real ggetr() + +begin + # Setup a graphics WCS that mimics the NDC coordinate WCS, + # but with clipping. + call ggview (WL_GP(wd), vl, vr, vb, vt) + call gseti (WL_GP(wd), G_WCS, WL_NDC_WCS(wd)) + call gsview (WL_GP(wd), vl, vr, vb, vt) + call gswind (WL_GP(wd), vl, vr, vb, vt) + call gseti (WL_GP(wd), G_CLIP, YES) + + # Setup the initial viewport. + WL_NEW_VIEW(wd,LEFT) = vl + WL_NEW_VIEW(wd,RIGHT) = vr + WL_NEW_VIEW(wd,BOTTOM) = vb + WL_NEW_VIEW(wd,TOP) = vt + + # Setup some parameters. + call gseti (WL_GP(wd), G_PLTYPE, GL_SOLID) + call gsetr (WL_GP(wd), G_PLWIDTH, LINE_SIZE) + + # Draw the edges of the viewport. + call gamove (WL_GP(wd), vl, vb) + call gadraw (WL_GP(wd), vr, vb) + call gadraw (WL_GP(wd), vr, vt) + call gadraw (WL_GP(wd), vl, vt) + call gadraw (WL_GP(wd), vl, vb) + + # Determine the tick mark size. + relative_size = max (abs (vr - vl), abs (vt - vb )) + WL_MAJ_TICK_SIZE(wd) = relative_size * WL_MAJ_TICK_SIZE(wd) + WL_MIN_TICK_SIZE(wd) = relative_size * WL_MIN_TICK_SIZE(wd) + + # Determine various character sizes. + WL_TITLE_SIZE(wd) = WL_TITLE_SIZE(wd) * relative_size + WL_AXIS_TITLE_SIZE(wd) = WL_AXIS_TITLE_SIZE(wd) * relative_size + WL_LABEL_SIZE(wd) = WL_LABEL_SIZE(wd) * relative_size + + # Now setup the general plotting WCS. + call gseti (WL_GP(wd), G_WCS, WL_PLOT_WCS(WD)) + call gsview (WL_GP(wd), vl, vr, vb, vt) + vl = real (WL_SCREEN_BOUNDARY(wd,LEFT)) + vr = real (WL_SCREEN_BOUNDARY(wd,RIGHT)) + vb = real (WL_SCREEN_BOUNDARY(wd,BOTTOM)) + vt = real (WL_SCREEN_BOUNDARY(wd,TOP)) + call gswind (WL_GP(wd), vl, vr, vb, vt) + call gseti (WL_GP(wd), G_CLIP, YES) + + # Set some characteristics of the graphics device. + call gseti (WL_GP(wd), G_TXQUALITY, GT_HIGH) + call gseti (WL_GP(wd), G_CLIP, YES) + call gsetr (WL_GP(wd), G_PLWIDTH, LINE_SIZE) + + # Determine the number of segments a "line" should consist of. + WL_LINE_SEGMENTS(wd) = int (min (ggetr (WL_GP(wd), "xr"), + ggetr (WL_GP(wd), "yr")) / 5) +end diff --git a/pkg/utilities/nttools/stxtools/word.x b/pkg/utilities/nttools/stxtools/word.x new file mode 100644 index 00000000..c6b33191 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/word.x @@ -0,0 +1,229 @@ +# Definition of delimeters used in parsing words + +define IS_DELIM (($1) <= ' ' || ($1) == ',') +define NOT_DELIM (($1) > ' ' && ($1) != ',') + +.help +.nf_________________________________________________________________________ + +The procedures in this file perform simple processing on lists of +words. These procedures count the number of words in a list, fetch +the next word in a list, find the n-th word in a list, check for an +exact match between a word and a list of words. A word is any group +of contiguous characters which are neither whitespace or commas. The +definition of whitespace is anomalous, it includes any character whose +integer value is less than or equal to a blank. Note that words cannot +be delimeted by quotes and that escape processing is not done. + +.endhelp____________________________________________________________________ + +#______________________________HISTORY______________________________________ +# +# B.Simon 20-Apr-1990 Modified versions of CDBS routines adb_*tok.x +# +#___________________________________________________________________________ + +# WORD_COUNT -- Return the number of words in a list of words + +int procedure word_count (list) + +char list[ARB] # i: List of words +#-- +char ch +int count, ic + +begin + + # The absolute value of count is the number of the current + # word of the list, count is negative if we are currently + # between words. + + count = 0 + + # Loop over all characters in the list + + for (ic = 1 ; list[ic] != EOS; ic = ic + 1) { + ch = list[ic] + + if (count > 0) { + if (IS_DELIM(ch)) + count = - count + + } else if (NOT_DELIM(ch)) { + count = - count + 1 + } + } + + return (abs(count)) +end + +# WORD_FETCH -- Retrieve next word from string + +int procedure word_fetch (str, ic, word, maxch) + +char str[ARB] # i: String containing words +int ic # io: Index of starting character +char word[ARB] # o: Word string +int maxch # i: Declared length of output string +#-- +char ch +int jc + +begin + # Skip leading whitespace or commas. Don't go past string terminator. + + for (ch = str[ic]; IS_DELIM(ch); ch = str[ic]) { + if (ch == EOS) + break + ic = ic + 1 + } + + # Copy characters to word. End when maxch is reached, or + # when commas, whitespace, or EOS is found + + for (jc = 1; jc <= maxch; jc = jc + 1) { + if (IS_DELIM(ch)) + break + + word[jc] = ch + ic = ic + 1 + ch = str[ic] + } + word[jc] = EOS + + # If loop is terminated because of maxch, eat remaining characters + # in field + + while (NOT_DELIM(ch)) { + ic = ic + 1 + ch = str[ic] + } + + # Return number of characters in word + + return (jc - 1) + +end + +# WORD_FIND -- Find the i-th word in a list of words + +int procedure word_find (index, list, word, maxch) + +int index # i: Index to word within list +char list[ARB] # i: List of words +char word[ARB] # o: Word returned by this procedure +int maxch # i: Declared length of output string +#-- +char ch +int count, ic, jc + +begin + # The absolute value of count is the number of the current + # word of the list, count is negative if we are currently + # between words + + count = 0 + + # Loop until i-th word is reached in list + + for (ic = 1 ; count < index && list[ic] != EOS; ic = ic + 1) { + ch = list[ic] + + if (count > 0) { + if (IS_DELIM(ch)) + count = - count + + } else if (NOT_DELIM(ch)) { + count = - count + 1 + } + } + + # If index is out of bounds, return zero + + if (index < 0 || index > count) + return (0) + + jc = 1 + for (ic = ic - 1; NOT_DELIM(list[ic]); ic = ic + 1) { + if (jc > maxch) + break + + word[jc] = list[ic] + jc = jc + 1 + } + word[jc] = EOS + + # Return number of characters in word + + return (jc - 1) +end + +# WORD_MATCH -- Return number of the word in the list which matches the word + +int procedure word_match (word, list) + +char word[ARB] # i: Word to be matched +char list[ARB] # i: List of words +#-- +char ch +int match, inword, ic, jc + +begin + # The absolute value of inword is the number of the current + # word of the list, inword is negative if we are currently + # between words in the list + + jc = 1 + match = 0 + inword = 0 + + # Loop over all characters in the list + + for (ic = 1 ; list[ic] != EOS; ic = ic + 1) { + ch = list[ic] + + # First case: current character is within a word + + if (inword > 0) { + + # Check for conversion to second case + + if (IS_DELIM(ch)) { + inword = - inword + + # Simultaneous end of word in list and word + # means a match has been found + + if (match != 0 && word[jc] == EOS) + break + else + match = 0 + + } else if (match != 0) { + + # Check for match between list and word + + if (ch == word[jc]) + jc = jc + 1 + else + match = 0 + } + + # Second case: current character is between words + # Check for conversion to first case + + } else if (NOT_DELIM(ch)) { + jc = 1 + ic = ic - 1 + inword = - inword + 1 + match = inword + } + } + + # If list ended before word, there was no match + + if (word[jc] != EOS) + match = 0 + + return (match) +end diff --git a/pkg/utilities/nttools/stxtools/xtwcs.x b/pkg/utilities/nttools/stxtools/xtwcs.x new file mode 100644 index 00000000..aa8b2798 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/xtwcs.x @@ -0,0 +1,1286 @@ +include <imhdr.h> +include <math.h> + +# This file contains the following high-level routines for converting +# between world coordinates and pixel coordinates: +# +# xt_wcs_init initialize struct for world coordinate system +# xt_wcs_init_c initialize from input cdelt, crota, etc +# xt_wcs_init_cd initialize from input CD matrix, etc +# xt_wcs_free deallocate wcs struct +# xt_wc_pix convert from world coordinates to pixel coordinates +# xt_pix_wc convert from pixel coordinates to world coordinates +# +# Phil Hodge, 27-Sept-1988 Created, based on code by Nelson & Zolt. +# Phil Hodge, 6-April-1990 CD matrix mult. was transposed in xt_pix_wc. +# Phil Hodge, 26-July-1991 In xt_e_ctype, change GBS to GLS (global sine). + +define LEN_WCS 136 # size of wcs struct for naxis <= 7 + +define W_VALID Memi[$1] # coordinates valid, YES or NO? +define W_NAXIS Memi[$1+1] # number of axes +define W_RA_AX Memi[$1+2] # which axis is RA? zero if none +define W_DEC_AX Memi[$1+3] # which axis is Dec? zero if none +define W_PROJECTION Memi[$1+4] # projection type + +# 6 is currently not used + +# 7 - 55: full CD matrix (7x7); units = e.g. degrees +# 56 - 104: LU decomposition of CD matrix +# 105 - 111: index returned by ludcmp for use by lubksb +# 112 - 118: reference pixel location +# 119 - 122: cosine & sine of declination at the reference pixel +# 123 - 136: coordinates at crpix; units = e.g. degrees + +define W_CD Memr[P2R($1+6 +($2-1)+($3-1)*7)] +define W_CDLU Memr[P2R($1+55 +($2-1)+($3-1)*7)] +define W_CDINDX Memr[P2R($1+104)] # this is an array of 7 +define W_CRPIX Memr[P2R($1+110+$2)] +define W_COSDEC Memd[P2D($1+118)] +define W_SINDEC Memd[P2D($1+120)] +define W_CRVAL Memd[P2D($1+120)+$2] + +# Projection types. + +define W_LINEAR 0 +define W_GNOMONIC 1 # TAN +define W_SINE 2 # SIN +define W_ARC 3 # ARC +define W_NORTH_POLAR 4 # NCP, north celestial pole (Westerbork) +define W_STEREOGRAPHIC 5 # STG (conformal) +define W_AITOFF 6 # AIT (equal-area) +define W_GLOBAL_SINE 7 # GLS (equal-area) +define W_MERCATOR 8 # MER (conformal) + + +# xt_wcs_init -- initialize wcs struct +# This routine allocates space for a structure describing the world +# coordinate system for an image, fills in the values or defaults, and +# returns a pointer to that structure. + +procedure xt_wcs_init (im, wcs) + +pointer im # i: pointer to image descriptor +pointer wcs # o: pointer to world coord system struct +#-- +real dummy # returned by ludcmp and ignored +int ira, idec # index of RA, Dec axes +int j, k # loop indexes +errchk xt_load_ctstruct + +begin + call calloc (wcs, LEN_WCS, TY_STRUCT) + + W_VALID(wcs) = YES # initial value + W_NAXIS(wcs) = IM_NDIM(im) + + call xt_load_wcsstruct (im, wcs) # get CRVAL, etc from image + + if (W_NAXIS(wcs) >= 2) { + + ira = W_RA_AX(wcs) + idec = W_DEC_AX(wcs) + + if (idec > 0) { + W_COSDEC(wcs) = cos (DEGTORAD(W_CRVAL(wcs,idec))) + W_SINDEC(wcs) = sin (DEGTORAD(W_CRVAL(wcs,idec))) + } else { + W_COSDEC(wcs) = 1.d0 + W_SINDEC(wcs) = 0.d0 + } + + # Copy the CD matrix to W_CDLU, and do the LU decomposition + # on W_CDLU in-place. + do k = 1, IM_MAXDIM + do j = 1, IM_MAXDIM + W_CDLU(wcs,j,k) = W_CD(wcs,j,k) + + iferr { + call ludcmp (W_CDLU(wcs,1,1), W_NAXIS(wcs), IM_MAXDIM, + W_CDINDX(wcs), dummy) + } then { + call mfree (wcs, TY_STRUCT) + call error (0, "xt_wcs_init: cd matrix is singular") + } + } +end + + +# xt_wcs_free -- deallocate wcs struct +# This routine deallocates space for a wcs structure. + +procedure xt_wcs_free (wcs) + +pointer wcs # io: pointer to world coord system struct +#-- + +begin + if (wcs != NULL) + call mfree (wcs, TY_STRUCT) +end + + +# xt_wcs_init_c -- initialize wcs struct +# xt_wcs_init_c and xt_wcs_init_cd allocate space for a structure +# describing the world coordinate system for an image, fill in the values +# or defaults, and return a pointer to that structure. They differ from +# xt_wcs_init in that these take the coordinate parameters as arguments +# rather than getting them from the image. +# xt_wcs_init_c takes cdelt & crota, and xt_wcs_init_cd takes the CD matrix. + +procedure xt_wcs_init_c (crval, crpix, cdelt, crota, ctype, naxis, wcs) + +double crval[naxis] # i: coordinate values at reference pixel +real crpix[naxis] # i: reference pixel +real cdelt[naxis] # i: pixel spacing +real crota # i: rotation angle (if 2-D) +char ctype[SZ_CTYPE,naxis] # i: e.g. "RA---TAN" +int naxis # i: size of arrays +pointer wcs # o: pointer to world coord system struct +#-- +real dummy # returned by ludcmp and ignored +int ira, idec # index of RA, Dec axes +int j, k # loop indexes +errchk ludcmp + +begin + do k = 1, naxis + if (cdelt[k] == 0.) + call error (0, "xt_wcs_init_c: zero value of CDELT") + + call calloc (wcs, LEN_WCS, TY_STRUCT) + + W_NAXIS(wcs) = naxis + W_VALID(wcs) = YES # initial value + + # Examine ctype to get ira, idec, proj_type. + call xt_e_ctype (ctype, naxis, ira, idec, W_PROJECTION(wcs)) + W_RA_AX(wcs) = ira + W_DEC_AX(wcs) = idec + + do k = 1, naxis { + W_CRVAL(wcs,k) = crval[k] + W_CRPIX(wcs,k) = crpix[k] + } + do k = naxis+1, IM_MAXDIM { + W_CRVAL(wcs,k) = 0.d0 + W_CRPIX(wcs,k) = 1. + } + + if (naxis == 1) { + + W_CD(wcs,1,1) = cdelt[1] + + } else if (naxis >= 2) { + + if (idec > 0) { + W_COSDEC(wcs) = cos (DEGTORAD(W_CRVAL(wcs,idec))) + W_SINDEC(wcs) = sin (DEGTORAD(W_CRVAL(wcs,idec))) + } else { + W_COSDEC(wcs) = 1.d0 + W_SINDEC(wcs) = 0.d0 + } + + # Convert cdelt & crota to the CD matrix. + call xt_to_cd (wcs, cdelt, crota, naxis) + + # Copy the CD matrix, and do the LU decomposition on W_CDLU. + do k = 1, IM_MAXDIM + do j = 1, IM_MAXDIM + W_CDLU(wcs,j,k) = W_CD(wcs,j,k) + + call ludcmp (W_CDLU(wcs,1,1), naxis, IM_MAXDIM, + W_CDINDX(wcs), dummy) + } +end + + +# xt_wcs_init_cd -- initialize wcs struct (CD) + +procedure xt_wcs_init_cd (crval, crpix, cd, ctype, naxis, wcs) + +double crval[naxis] # i: coordinate values at reference pixel +real crpix[naxis] # i: reference pixel +real cd[naxis,naxis] # i: CD matrix +char ctype[SZ_CTYPE,naxis] # i: e.g. "RA---TAN" +int naxis # i: size of arrays +pointer wcs # o: pointer to world coord system struct +#-- +real dummy # returned by ludcmp and ignored +int ira, idec # index of RA, Dec axes +int j, k # loop indexes + +begin + call calloc (wcs, LEN_WCS, TY_STRUCT) + + W_NAXIS(wcs) = naxis + W_VALID(wcs) = YES # initial value + + # Examine ctype to get ira, idec, proj_type. + call xt_e_ctype (ctype, naxis, ira, idec, W_PROJECTION(wcs)) + W_RA_AX(wcs) = ira + W_DEC_AX(wcs) = idec + + do k = 1, naxis { + W_CRVAL(wcs,k) = crval[k] + W_CRPIX(wcs,k) = crpix[k] + } + do k = naxis+1, IM_MAXDIM { + W_CRVAL(wcs,k) = 0.d0 + W_CRPIX(wcs,k) = 1. + } + + if (naxis == 1) { + + W_CD(wcs,1,1) = cd[1,1] + + } else if (naxis >= 2) { + + if (idec > 0) { + W_COSDEC(wcs) = cos (DEGTORAD(W_CRVAL(wcs,idec))) + W_SINDEC(wcs) = sin (DEGTORAD(W_CRVAL(wcs,idec))) + } else { + W_COSDEC(wcs) = 1.d0 + W_SINDEC(wcs) = 0.d0 + } + + # Assign initial values to the CD matrix. + do k = 1, IM_MAXDIM { + do j = 1, IM_MAXDIM { + if (j == k) { + W_CD(wcs,k,k) = 1. + W_CDLU(wcs,k,k) = 1. + } else { + W_CD(wcs,j,k) = 0. + W_CDLU(wcs,j,k) = 0. + } + } + } + + # Copy the CD matrix, and do the LU decomposition on W_CDLU. + do k = 1, naxis { + do j = 1, naxis { + W_CD(wcs,j,k) = cd[j,k] + W_CDLU(wcs,j,k) = cd[j,k] + } + } + + iferr { + call ludcmp (W_CDLU(wcs,1,1), naxis, IM_MAXDIM, + W_CDINDX(wcs), dummy) + } then { + call mfree (wcs, TY_STRUCT) + call error (0, "xt_wcs_init_cd: cd matrix is singular") + } + } +end + +# xt_to_cd -- from cdelt & crota to cd matrix +# This routine computes the CD matrix from CDELT and CROTA. + +procedure xt_to_cd (wcs, cdelt, crota, naxis) + +pointer wcs # i: pointer to world coord system struct +real cdelt[naxis] # i: pixel spacing +real crota # i: rotation angle (if 2-D) +int naxis # i: size of arrays +#-- +real cosrota, sinrota # cosine & sine of crota +real sign_cdelt[2] # one, with sign of cdelt1 or cdelt2 +int ira, idec # index of RA, Dec axes +int j, k # loop indexes + +begin + ira = W_RA_AX(wcs) + idec = W_DEC_AX(wcs) + + if ( ! IS_INDEFD(crota) ) { + cosrota = cos (DEGTORAD(crota)) + sinrota = sin (DEGTORAD(crota)) + } else { + cosrota = 1.d0 + sinrota = 0.d0 + } + + # Initial values for CD matrix. + do k = 1, IM_MAXDIM { + do j = 1, IM_MAXDIM { + if (j == k) + W_CD(wcs,k,k) = 1. + else + W_CD(wcs,j,k) = 0. + } + } + do k = 1, naxis + W_CD(wcs,k,k) = cdelt[k] + + if (ira > 0 && idec > 0) { + + if (cdelt[ira] >= 0.) + sign_cdelt[1] = 1. + else + sign_cdelt[1] = -1. + + if (cdelt[idec] >= 0.) + sign_cdelt[2] = 1. + else + sign_cdelt[2] = -1. + + W_CD(wcs,ira,ira) = cdelt[ira] * cosrota + W_CD(wcs,ira,idec) = abs (cdelt[idec]) * sign_cdelt[1] * sinrota + W_CD(wcs,idec,ira) = -abs (cdelt[ira]) * sign_cdelt[2] * sinrota + W_CD(wcs,idec,idec) = cdelt[idec] * cosrota + } +end + +# xt_e_ctype -- examine ctype +# Examine each element of the ctype array to find which axes (if any) +# are RA & Dec (or glon & glat, etc). Also get the projection type, +# such as gnomonic, if this was specified in ctype. + +procedure xt_e_ctype (ctype, naxis, ra_axis, dec_axis, proj_type) + +char ctype[SZ_CTYPE,naxis] # i: coordinate type, e.g. "RA---TAN" +int naxis # i: dimension +int ra_axis # o: which axis is RA (or glon, etc)? +int dec_axis # o: which axis is Dec (or glat, etc)? +int proj_type # o: type of projection +#-- +char lctype[SZ_CTYPE] # local copy of an element of ctype +char dash # '-' +int k +int index # index of '-' in ctype +int strncmp(), strldx() + +begin + # Assign defaults. + ra_axis = 0 + dec_axis = 0 + if (naxis == 1) + proj_type = W_LINEAR + else + proj_type = W_GNOMONIC + + # Search for "RA", "DEC", etc. + do k = 1, naxis { + # Make a local copy of ctype & make sure it's upper case. + call strcpy (ctype[1,k], lctype, SZ_CTYPE) + call strupr (lctype) + + if (strncmp (lctype, "RA", 2) == 0) + ra_axis = k + else if (strncmp (lctype, "DEC", 3) == 0) + dec_axis = k + + else if (strncmp (lctype, "GLON", 4) == 0) + ra_axis = k + else if (strncmp (lctype, "LL", 2) == 0) + ra_axis = k + else if (strncmp (lctype, "UU", 2) == 0) + ra_axis = k + else if (strncmp (lctype, "ELON", 4) == 0) + ra_axis = k + + else if (strncmp (lctype, "GLAT", 4) == 0) + dec_axis = k + else if (strncmp (lctype, "MM", 2) == 0) + dec_axis = k + else if (strncmp (lctype, "VV", 2) == 0) + dec_axis = k + else if (strncmp (lctype, "ELAT", 4) == 0) + dec_axis = k + } + + if (ra_axis > 0) + k = ra_axis + else if (dec_axis > 0) + k = dec_axis + else + k = 0 + + # If at least one of the axes is like RA or Dec, check to see + # whether a projection type was specified. + if (k > 0) { + dash = '-' + index = strldx (dash, lctype) + if (index > 0) { + index = index + 1 + if (strncmp (lctype[index], "TAN", 3) == 0) + proj_type = W_GNOMONIC + else if (strncmp (lctype[index], "SIN", 3) == 0) + proj_type = W_SINE + else if (strncmp (lctype[index], "ARC", 3) == 0) + proj_type = W_ARC + else if (strncmp (lctype[index], "NCP", 3) == 0) + proj_type = W_NORTH_POLAR + else if (strncmp (lctype[index], "STG", 3) == 0) + proj_type = W_STEREOGRAPHIC + else if (strncmp (lctype[index], "AIT", 3) == 0) + proj_type = W_AITOFF + else if (strncmp (lctype[index], "GLS", 3) == 0) + proj_type = W_GLOBAL_SINE + else if (strncmp (lctype[index], "MER", 3) == 0) + proj_type = W_MERCATOR + } + } +end + + +define SZ_PNAME 8 + +# xt_load_wcsstruct -- load coordinate information +# Get the coordinate information from the image, and load +# that info into the wcs structure. + +procedure xt_load_wcsstruct (im, wcs) + +pointer im # i: pointer to image header struct +pointer wcs # i: pointer to world coord system struct +#-- +char pname[SZ_PNAME] +char ctype[SZ_CTYPE,IM_MAXDIM] +int naxis, iax # dimension of image; loop index for axis +bool cdm_found # true if CD matrix present in image +int imaccf() +double imgetd() +real imgetr() +errchk imgstr, imgetd, imgetr, xt_g_cd_matrix, xt_c_cd_matrix + +begin + naxis = IM_NDIM(im) + + # Get the coordinate info. If anything is missing set W_VALID to NO. + do iax = 1, naxis { + + # CTYPE for each axis. + call sprintf (pname, SZ_PNAME, "ctype%d") + call pargi (iax) + if (imaccf (im, pname) == YES) { + call imgstr (im, pname, ctype[1,iax], SZ_CTYPE) + } else { + call strcpy ("PIXEL", ctype[1,iax], SZ_CTYPE) + W_VALID(wcs) = NO + } + + # CRVAL for each axis + call sprintf (pname, SZ_PNAME, "crval%d") + call pargi (iax) + if (imaccf (im, pname) == YES) { + W_CRVAL(wcs,iax) = imgetd (im, pname) + } else { + W_CRVAL(wcs,iax) = 0.d0 + W_VALID(wcs) = NO + } + + # CRPIX for each axis + call sprintf (pname, SZ_PNAME, "crpix%d") + call pargi (iax) + if (imaccf (im, pname) == YES) { + W_CRPIX(wcs,iax) = imgetr (im, pname) + } else { + W_CRPIX(wcs,iax) = 1. + W_VALID(wcs) = NO + } + } + # Assign reasonable values to the unused elements. + do iax = naxis+1, IM_MAXDIM { + W_CRVAL(wcs,iax) = 0.d0 + W_CRPIX(wcs,iax) = 1. + } + + # Examine ctype array. + call xt_e_ctype (ctype, naxis, + W_RA_AX(wcs), W_DEC_AX(wcs), W_PROJECTION(wcs)) + + # First try to get the CD matrix, and if it isn't there + # get CDELT and CROTA and convert to CD. + + call xt_g_cd_matrix (im, wcs, naxis, cdm_found) + + if ( ! cdm_found ) + call xt_c_cd_matrix (im, wcs, naxis) +end + + +# xt_g_cd_matrix -- get CD matrix +# If the CD matrix is present, get the values and place them into the +# wcs structure. Note that we assume that if *any* of the CD matrix +# parameters are there, they are *all* there. + +define TOLER 1.e-5 + +procedure xt_g_cd_matrix (im, wcs, naxis, cdm_found) + +pointer im # i: image pointer +pointer wcs # i: pointer to wcs structure +int naxis # i: number of axes in image +bool cdm_found # o: true if CD matrix found +#-- +real cd_matrix[IM_MAXDIM,IM_MAXDIM] # the CD matrix +char pname[SZ_PNAME] +int i, j +int imaccf() +real imgetr() +errchk imgetr + +begin + # This is reset below if any element of the CD matrix is found. + cdm_found = false + + # Assign default values. + do j = 1, IM_MAXDIM + do i= 1, IM_MAXDIM + if (i == j) + cd_matrix[i,j] = 1. + else + cd_matrix[i,j] = 0. + + # Get each element of the CD matrix. + do j = 1, naxis { + do i = 1, naxis { + call sprintf (pname, SZ_PNAME, "cd%d_%d") + call pargi (i) + call pargi (j) + if (imaccf (im, pname) == YES) { + cd_matrix[i,j] = imgetr (im, pname) + cdm_found = true + } + } + } + + # Copy to the wcs structure. + do j = 1, IM_MAXDIM + do i = 1, IM_MAXDIM + W_CD(wcs,i,j) = cd_matrix[i,j] +end + + +# xt_c_cd_matrix -- create CD matrix +# If the CD matrix is not present, get the values of CDELT & CROTA, +# convert to the CD matrix, and store the values in the wcs structure. +# Since this is called after trying unsuccessfully to get the CD matrix, +# if cdelt or crota is not present W_VALID will be reset to NO. + +procedure xt_c_cd_matrix (im, wcs, naxis) + +pointer im # i: image pointer +pointer wcs # i: pointer to wcs structure +int naxis # i: number of axes in image +#-- +char pname[SZ_PNAME] # parameter name (e.g. "cdelt1") +real cdelt[IM_MAXDIM] # pixel spacing +real crota # rotation angle in degrees +int k # loop index for axis +int imaccf() +real imgetr() +errchk imgetr + +begin + do k = 1, naxis { + + # CDELT for each axis. + call sprintf (pname, SZ_PNAME, "cdelt%d") + call pargi (k) + if (imaccf (im, pname) == YES) { + cdelt[k] = imgetr (im, pname) + if (cdelt[k] == 0.) + call error (0, "xt_c_cd_matrix: cdelt is zero") + } else { + cdelt[k] = 1. + W_VALID(wcs) = NO + } + } + + # For a 1-D image, assign CD1_1 and return. + if (naxis == 1) { + W_CD(wcs,1,1) = cdelt[1] + return + } + + # CROTA (only one). + call strcpy ("crota1", pname, SZ_PNAME) + if (imaccf (im, pname) == YES) { + crota = imgetr (im, pname) + } else { + crota = 0. + W_VALID(wcs) = NO + } + + # Compute CD matrix from CDELT & CROTA. + call xt_to_cd (wcs, cdelt, crota, naxis) +end + + +# xt_wc_pix -- wcs to pixels +# This routine converts world coordinates to pixel coordinates. +# +# In the 1-D case, CRVAL is subtracted from the coordinate, the +# result is divided by CDELT (same as CD1_1), and CRPIX is added. +# +# For 2-D or higher dimension, if two of the axes are like RA and Dec, +# the input coordinates are converted to standard coordinates Xi +# and Eta. The (Xi, Eta) vector is then multiplied on the left by +# the inverse of the CD matrix, and CRPIX is added. +# The units for axes like Ra & Dec are degrees, not hours or radians. +# For linear axes the conversion is the same as for 1-D. + +procedure xt_wc_pix (wcs, phys, pix, naxis) + +pointer wcs # i: pointer to world coord system struct +double phys[naxis] # i: physical (world) coordinates (e.g. degrees) +real pix[naxis] # o: pixel coordinates +int naxis # i: size of arrays +#-- +double delta_ra # RA of object - RA at reference pixel +double dra_r, dec_r # delta_ra & declination in radians +double xi_r, eta_r # xi & eta in radians +real dphys[IM_MAXDIM] # phys coord - reference coord +int ira, idec # index of RA, Dec axes +int k # loop index +errchk xt_wp_ncp, xt_wp_mer + +begin + do k = 1, naxis + dphys[k] = phys[k] - W_CRVAL(wcs,k) + + if (naxis == 1) { + + pix[1] = dphys[1] / W_CD(wcs,1,1) + W_CRPIX(wcs,1) + + } else { + + ira = W_RA_AX(wcs) + idec = W_DEC_AX(wcs) + + # Convert RA & Dec to Xi & Eta (standard coordinates). + if (ira > 0 && idec > 0) { + + delta_ra = phys[ira] - W_CRVAL(wcs,ira) # double prec + dra_r = DEGTORAD (delta_ra) + dec_r = DEGTORAD (phys[idec]) + + switch (W_PROJECTION(wcs)) { + case W_GNOMONIC: + call xt_wp_tan (wcs, dra_r, dec_r, xi_r, eta_r) + case W_SINE: + call xt_wp_sin (wcs, dra_r, dec_r, xi_r, eta_r) + case W_ARC: + call xt_wp_arc (wcs, dra_r, dec_r, xi_r, eta_r) + case W_NORTH_POLAR: + call xt_wp_ncp (wcs, dra_r, dec_r, xi_r, eta_r) + case W_STEREOGRAPHIC: + call xt_wp_stg (wcs, dra_r, dec_r, xi_r, eta_r) + case W_AITOFF: + call xt_wp_ait (wcs, dra_r, dec_r, xi_r, eta_r) + case W_GLOBAL_SINE: + call xt_wp_gls (wcs, dra_r, dec_r, xi_r, eta_r) + case W_MERCATOR: + call xt_wp_mer (wcs, dra_r, dec_r, xi_r, eta_r) + } + + dphys[ira] = RADTODEG (xi_r) # xi, eta in degrees + dphys[idec] = RADTODEG (eta_r) + } + + # Use LU backsubstitution to get pixel coords from physical coords. + call lubksb (W_CDLU(wcs,1,1), naxis, IM_MAXDIM, + W_CDINDX(wcs), dphys) # dphys is modified in-place + do k = 1, naxis + pix[k] = dphys[k] + W_CRPIX(wcs,k) # copy to output + } +end + + +# xt_pix_wc -- pixels to wcs +# This routine converts pixel coordinates to world coordinates. +# +# In the 1-D case, CRPIX is subtracted from the pixel coordinate, +# the result is multiplied by CDELT (same as CD1_1), and CRVAL is added. +# +# For 2-D or higher dimension, CRPIX is subtracted, and the result is +# multiplied on the left by the CD matrix. If two of the axes are like +# RA and Dec, the pixel coordinates are converted to standard coordinates +# Xi and Eta. The (xi, eta) vector is then converted to differences +# between RA and Dec and CRVAL, and then CRVAL is added to each coordinate. + +procedure xt_pix_wc (wcs, pix, phys, naxis) + +pointer wcs # i: pointer to world coord system struct +real pix[naxis] # i: pixel coordinates +double phys[naxis] # o: physical (world) coordinates +int naxis # i: size of arrays +#-- +double dpix[IM_MAXDIM] # pix coord - crpix +double sum # for matrix multiplication +double dra_r, dec_r # delta_ra & declination in radians +double xi_r, eta_r # xi & eta in radians +int ira, idec # index of RA, Dec axes +int j, k # loop indexes + +begin + do k = 1, naxis + dpix[k] = pix[k] - W_CRPIX(wcs,k) + + if (naxis == 1) { + + phys[1] = dpix[1] * W_CD(wcs,1,1) + W_CRVAL(wcs,1) + + } else { + + do j = 1, naxis { + sum = 0.d0 + do k = 1, naxis + sum = sum + W_CD(wcs,j,k) * dpix[k] + phys[j] = sum + } + + ira = W_RA_AX(wcs) + idec = W_DEC_AX(wcs) + + # Convert Xi & Eta (standard coordinates) to RA & Dec. + if (ira > 0 && idec > 0) { + xi_r = DEGTORAD (phys[ira]) + eta_r = DEGTORAD (phys[idec]) + + switch (W_PROJECTION(wcs)) { + case W_GNOMONIC: + call xt_pw_tan (wcs, xi_r, eta_r, dra_r, dec_r) + case W_SINE: + call xt_pw_sin (wcs, xi_r, eta_r, dra_r, dec_r) + case W_ARC: + call xt_pw_arc (wcs, xi_r, eta_r, dra_r, dec_r) + case W_NORTH_POLAR: + call xt_pw_ncp (wcs, xi_r, eta_r, dra_r, dec_r) + case W_STEREOGRAPHIC: + call xt_pw_stg (wcs, xi_r, eta_r, dra_r, dec_r) + case W_AITOFF: + call xt_pw_ait (wcs, xi_r, eta_r, dra_r, dec_r) + case W_GLOBAL_SINE: + call xt_pw_gls (wcs, xi_r, eta_r, dra_r, dec_r) + case W_MERCATOR: + call xt_pw_mer (wcs, xi_r, eta_r, dra_r, dec_r) + } + + phys[idec] = RADTODEG (dec_r) + phys[ira] = RADTODEG (dra_r) + W_CRVAL(wcs,ira) + if (phys[ira] < 0.d0) + phys[ira] = phys[ira] + 360.d0 + } + do k = 1, naxis + if (k != ira && k != idec) + phys[k] = phys[k] + W_CRVAL(wcs,k) + } +end + + +# xt_wp_tan -- convert from ra & dec using gnomonic projection + +procedure xt_wp_tan (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdra, sindra # cos & sin of dra_r +double cosdec, sindec # cos & sin of object declination +double cosdist # cos of dist from ref pixel to object + +begin + cosdra = cos (dra_r) + sindra = sin (dra_r) + + cosdec = cos (dec_r) + sindec = sin (dec_r) + + cosdist = sindec * W_SINDEC(wcs) + cosdec * W_COSDEC(wcs) * cosdra + + xi_r = cosdec * sindra / cosdist + eta_r = (sindec * W_COSDEC(wcs) - + cosdec * W_SINDEC(wcs) * cosdra) / cosdist +end + + +# xt_pw_tan -- convert to ra & dec using gnomonic projection +# In rectangular coordinates the vector (1, xi, eta) points toward +# the object; the origin is the observer's location, the x-axis points +# toward the reference pixel, the y-axis is in the direction of increasing +# right ascension, and the z-axis is in the direction of increasing +# declination. The coordinate system is then rotated by the declination so +# the x-axis passes through the equator at the RA of the reference pixel; +# the components of the vector in this coordinate system are used to +# compute (RA - reference_RA) and declination. + +procedure xt_pw_tan (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double x, y, z # vector (not unit length) pointing toward object + +begin + # Rotate the rectangular coordinate system of the vector (1, xi, eta) + # by the declination so the x-axis will pass through the equator. + x = W_COSDEC(wcs) - eta_r * W_SINDEC(wcs) + y = xi_r + z = W_SINDEC(wcs) + eta_r * W_COSDEC(wcs) + + if (x == 0.d0 && y == 0.d0) + dra_r = 0.d0 + else + dra_r = atan2 (y, x) + dec_r = atan2 (z, sqrt (x*x + y*y)) +end + + +# xt_wp_sin -- convert from ra & dec using sine projection +# +# Reference: AIPS Memo No. 27 by Eric W. Greisen + +procedure xt_wp_sin (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdra, sindra # cos & sin of delta_ra +double cosdec, sindec # cos & sin of object declination + +begin + cosdra = cos (dra_r) + sindra = sin (dra_r) + + cosdec = cos (dec_r) + sindec = sin (dec_r) + + xi_r = cosdec * sindra + eta_r = sindec * W_COSDEC(wcs) - cosdec * W_SINDEC(wcs) * cosdra +end + + +# xt_pw_sin -- convert to ra & dec using sine projection +# In rectangular coordinates the vector (v1, xi, eta), where +# v1 = sqrt (1 - xi**2 - eta**2), is the location of the object on the +# unit celestial sphere. The x-axis points toward the reference pixel, +# the y-axis is in the direction of increasing right ascension, and the +# z-axis is in the direction of increasing declination. The coordinate +# system is then rotated (around the y-axis) by the declination so the +# x-axis passes through the equator at the RA of the reference pixel; +# the components of the vector in this coordinate system are used to +# compute (RA - reference_RA) and declination. + +procedure xt_pw_sin (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double v1 # x component of unit vector +double x, y, z # unit vector with x[1] pointing toward equator + +begin + v1 = sqrt (1.d0 - xi_r*xi_r - eta_r*eta_r) + + # Rotate the rectangular coordinate system of the vector (v1, xi, eta) + # by the declination so the x-axis will pass through the equator. + x = v1 * W_COSDEC(wcs) - eta_r * W_SINDEC(wcs) + y = xi_r + z = v1 * W_SINDEC(wcs) + eta_r * W_COSDEC(wcs) + + if (x == 0.d0 && y == 0.d0) + dra_r = 0.d0 + else + dra_r = atan2 (y, x) + dec_r = atan2 (z, sqrt (x*x + y*y)) +end + + +# xt_wp_arc -- convert from ra & dec using arc projection +# +# Reference: AIPS Memo No. 27 by Eric W. Greisen + +procedure xt_wp_arc (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdra, sindra # cos & sin of delta_ra +double cosdec, sindec # cos & sin of object declination +double theta # distance (radians) from ref pixel to object +double r # theta / sin (theta) + +begin + cosdra = cos (dra_r) + sindra = sin (dra_r) + + cosdec = cos (dec_r) + sindec = sin (dec_r) + + theta = acos (sindec * W_SINDEC(wcs) + cosdec * W_COSDEC(wcs) * cosdra) + if (theta == 0.d0) + r = 1.d0 + else + r = theta / sin (theta) + + xi_r = r * cosdec * sindra + eta_r = r * (sindec * W_COSDEC(wcs) - cosdec * W_SINDEC(wcs) * cosdra) +end + + +# xt_pw_arc -- convert to ra & dec using arc projection +# The rectangular coordinates of the pixel on a unit celestial sphere +# are computed in a coordinate system such that the x-axis points toward +# the reference pixel, the y-axis is in the direction of increasing right +# ascension, and the z-axis is in the direction of increasing declination. +# The coordinate system is then rotated (around the y-axis) by the +# declination so the x-axis passes through the equator at the RA of the +# reference pixel; the components of the vector in this coordinate system +# are used to compute (RA - reference_RA) and declination. + +procedure xt_pw_arc (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double theta # arc length, i.e. sqrt (xi**2 + eta**2) +double v[3] # unit vector with v[1] pointing toward ref pixel +double x, y, z # vector with x[1] pointing toward equator + +begin + theta = sqrt (xi_r*xi_r + eta_r*eta_r) + if (theta == 0.d0) { + v[1] = 1.d0 + v[2] = 0.d0 + v[3] = 0.d0 + } else { + v[1] = cos (theta) + v[2] = sin (theta) / theta * xi_r + v[3] = sin (theta) / theta * eta_r + } + + # Rotate the rectangular coordinate system of the vector v by the + # declination so the x-axis will pass through the equator. + x = v[1] * W_COSDEC(wcs) - v[3] * W_SINDEC(wcs) + y = v[2] + z = v[1] * W_SINDEC(wcs) + v[3] * W_COSDEC(wcs) + + if (x == 0.d0 && y == 0.d0) + dra_r = 0.d0 + else + dra_r = atan2 (y, x) + dec_r = atan2 (z, sqrt (x*x + y*y)) +end + + +# xt_wp_ncp -- convert from ra & dec using ncp projection +# +# References: +# AIPS Memo No. 27 by Eric W. Greisen +# Data Processing for the Westerbork Synthesis Radio Telescope +# by W. N. Brouw + +procedure xt_wp_ncp (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdra, sindra # cos & sin of delta_ra +double cosdec # cos of object declination + +begin + if (W_SINDEC(wcs) == 0.) + call error (1, "NCP projection: dec is zero") + + cosdra = cos (dra_r) + sindra = sin (dra_r) + + cosdec = cos (dec_r) + + xi_r = - cosdec * sindra + eta_r = (W_COSDEC(wcs) - cosdec * cosdra) / W_SINDEC(wcs) +end + + +# xt_pw_ncp -- convert to ra & dec using ncp projection +# +# References: +# AIPS Memo No. 27 by Eric W. Greisen +# Data Processing for the Westerbork Synthesis Radio Telescope +# by W. N. Brouw + +procedure xt_pw_ncp (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double temp + +begin + temp = W_COSDEC(wcs) - eta_r * W_SINDEC(wcs) + + dra_r = atan2 (-xi_r, temp) + dec_r = acos (temp / cos (dra_r)) + if (W_SINDEC(wcs) < 0) + dec_r = -dec_r +end + + +# xt_wp_gls -- convert from ra & dec using global-sine projection +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_wp_gls (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdec # cos of object declination +double temp # delta RA +int idec # which axis is declination axis + +begin + cosdec = cos (dec_r) + idec = W_DEC_AX(wcs) + + temp = dra_r + + # Put dra_r on the interval (-180,+180] degrees. + if (temp <= -PI) + temp = temp + TWOPI + if (temp > PI) + temp = temp - TWOPI + + xi_r = temp * cosdec + + if (idec > 0) + eta_r = dec_r - DEGTORAD (W_CRVAL(wcs,idec)) + else + eta_r = dec_r +end + + +# xt_pw_gls -- convert to ra & dec using global-sine projection +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_pw_gls (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double cosdec # cosine of object declination +int idec # which axis is declination axis + +begin + idec = W_DEC_AX(wcs) + if (idec > 0) + dec_r = eta_r + DEGTORAD (W_CRVAL(wcs,idec)) + else + dec_r = eta_r + + cosdec = cos (dec_r) + if (cosdec > 0.d0) + dra_r = xi_r / cosdec + else + dra_r = 0.d0 +end + +# xt_wp_stg -- convert from ra & dec using stereographic projection +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_wp_stg (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdra, sindra # cos & sin of dra_r +double cosdec, sindec # cos & sin of object declination +double cosdist # cos of dist from ref pixel to object +double sincos # sin (theta) * cos (phi) + +begin + cosdra = cos (dra_r) + sindra = sin (dra_r) + + cosdec = cos (dec_r) + sindec = sin (dec_r) + + cosdist = sindec * W_SINDEC(wcs) + cosdec * W_COSDEC(wcs) * cosdra + sincos = sindec * W_COSDEC(wcs) - cosdec * W_SINDEC(wcs) * cosdra + + xi_r = 2.d0 * cosdec * sindra / (1.d0 + cosdist) + eta_r = 2.d0 * sincos / (1.d0 + cosdist) +end + + +# xt_pw_stg -- convert to ra & dec using stereographic projection + +procedure xt_pw_stg (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double rho2 # square of distance from reference pixel +double scale # factor to reduce xi, eta to y, z +double x, y, z # unit vector toward object +double temp + +begin + rho2 = xi_r * xi_r + eta_r * eta_r + + x = (4.d0 - rho2) / (4.d0 + rho2) + scale = (x + 1.d0) / 2.d0 + + y = xi_r * scale + z = eta_r * scale + + temp = x * W_COSDEC(wcs) - z * W_SINDEC(wcs) + z = x * W_SINDEC(wcs) + z * W_COSDEC(wcs) + x = temp + + if (x == 0.d0 && y == 0.d0) + dra_r = 0.d0 + else + dra_r = atan2 (y, x) + dec_r = atan2 (z, sqrt (x*x + y*y)) +end + + +# xt_wp_ait -- convert from ra & dec using Aitoff projection +# +# Note that the declination at the reference pixel is ignored and is +# assumed to be zero. The algorithms given in the AIPS reference do +# allow for a non-zero declination at the reference pixel. +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_wp_ait (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double z # temp variable +double cosdec # cosine of declination + +begin + cosdec = cos (dec_r) + z = sqrt ((1.d0 + cosdec * cos (dra_r/2.d0)) / 2.d0) + + xi_r = 2.d0 * cosdec * sin (dra_r/2.d0) / z + eta_r = sin (dec_r) / z +end + + +# xt_pw_ait -- convert to ra & dec using Aitoff projection +# +# Note that the declination at the reference pixel is ignored and is +# assumed to be zero. The algorithms given in the AIPS reference do +# allow for a non-zero declination at the reference pixel. +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_pw_ait (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double z # temp variable +double cosdec # cosine of declination + +begin + z = sqrt (1.d0 - xi_r*xi_r/16.d0 - eta_r*eta_r/4.d0) + + dec_r = asin (eta_r * z) + cosdec = cos (dec_r) + + if (cosdec > 0.d0) { + dra_r = 2.d0 * asin (xi_r * z / (2.d0 * cosdec)) + } else { + dra_r = 0.d0 + } +end + + +# xt_wp_mer -- convert from ra & dec using Mercator projection +# +# Note that the declination at the reference pixel is ignored and is +# assumed to be zero. The algorithms given in the AIPS reference do +# allow for a non-zero declination at the reference pixel. +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_wp_mer (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double temp + +begin + xi_r = dra_r + temp = (dec_r + HALFPI) / 2.d0 + if (temp >= HALFPI || temp <= 0.d0) + call error (1, "invalid declination for Mercator projection") + eta_r = log (tan (temp)) +end + + +# xt_pw_mer -- convert to ra & dec using Mercator projection +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_pw_mer (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- + +begin + dra_r = xi_r + dec_r = 2.d0 * atan (exp (eta_r)) - HALFPI +end |