diff options
Diffstat (limited to 'pkg/xtools')
438 files changed, 57419 insertions, 0 deletions
diff --git a/pkg/xtools/README b/pkg/xtools/README new file mode 100644 index 00000000..394f71f6 --- /dev/null +++ b/pkg/xtools/README @@ -0,0 +1,12 @@ + +This directory contains miscellaneous tools written in the spp language. +While not really system routines or mathematical library routines, these +library routines are nonetheless sufficiently general purpose to justify +making them publically available. Reference library "libxtools.a" (-lxtools +on the xc command line) to access these routines. + +IRAF Group members are encouraged to add to the tools. To install a new +tool: (1) copy the .x source into the directory or subdirectory, (2) Enter +the name of each file followed by any dependency files into the mkpkg file, +and (3) enter the UNIX command "mkpkg". This will compile the new modules and +add them to the "libxtools.a" library. diff --git a/pkg/xtools/Revisions b/pkg/xtools/Revisions new file mode 100644 index 00000000..053bfc48 --- /dev/null +++ b/pkg/xtools/Revisions @@ -0,0 +1,1008 @@ +.help revisions Jun88 pkg.xtools +.nf + +inlfit/ingfit.gx + The 'oldwts' pointer was being used explicitly with Memr, changed to use + 'Mem$t' so the appropriate type is used (5/4/13, MJF) + +rmsorted.x + A 64-bit problem was fixed. (12/5/11, Valdes) + +catquery/cqdef.x +catquery/cqquery.x +catquery/cqimquery.x + Modified the URL access to use the new url_get() procedure as a + compile-time option. This allows access to servers that may + redirect the URL or return some other http error. (10/5/11, MJF) + +fixpix/ytpmmap.x + The world matching was not right. It may still have bugs but the + discovered problem has been fixed. (3/3/11, Valdes) + +======= +2.15.1a +======= + +pkg/xtools/icfit/icdeviant.gx + There were two bugs related to growing. First, the logic was wrong. + Second, in one place the grow parameter was treated as being in pixels + and in another as being in user coordinate units. + (6/28/10, Valdes) + +pkg/xtools/xtextns.x + Pixel list masks were not recognized as images. + (2/13/09, Valdes) + +lib/pkg/rmsorted.h +pkg/xtools/rmmed.x +pkg/xtools/rmsorted.x + Modified the running median library to allow running minimum and + running maximum. An argument addition required a change in the + runmed task but there was no functional change. + (10/29/08, Valdes) + +xtextns.x + 1. The wrong ranges package was used for the extension versions. Calling the correct one requires extension versions to be positive integers. + 2. The extension version was not being matched correctly. This may + have happened when switching to using the mef library. + (8/25/08, Valdes) + +fixpix/ytpmmap.x + The inefficiencies in evaluating the WCS were addressed. + (3/18/08, Valdes) + +fixpix/ytpmmap.x + Fixed a couple of bugs that could result in a floating point exception. + (3/17/08, Valdes) + +rmsorted.x + This routine was modified, including adding and argument, to + support the clipping of bright values. + (2/29/08, Valdes) + +rmmed.x + This general package of running median routines was moved from + images$imfilter/src. It was enhanced by allowing clipping of + bright sources. This means a new argument, nclip, is required. + (2/29/08, Valdes) + +fixpix/ytpmmap.x + 1. Any number of '^' characters can be in the name at any point to + invert or uninvert a mask. This is needed if an application wants + to invert the mask specified by the user which may also include '^'. + This also allows strings like !^foo or ^!foo. + 2. The pmmatch variable may not be "world N" where N is the maximum + input mask value to be preserved in the output mask. This value + is used to optimize the internal bit array to the smallest it + can be consistent with the desired value. A value of "world" + is equivalent to "world 1". + (2/5/08, Valdes) + +xtbitarray.x + Generalized to support different number of bits per element. The + value is now set by specifying a maximum value. All values greater + than the maximum are set to the maximum. (2/5/08, valdes) + +inlfit/innlinit.gx + Removed an extra argument from the nlfree$t() call (1/16/08, MJF) + +fixpix/ytpmmap.x + 1. A feature to match masks in world coordinates, but only as a + boolean mask, was added. + 2. The way the pixel mask matching is selected was generalized. + The matching type is specified as a string with values + "logical", "physical", "world", or "offset". An application + may also specify an environment variable which the user may + use to specify the type. If the application specifies one of + the types then the environment variable "pmmatch" may be used + to override the application. + (1/9/08, Valdes) + +xtbitarray.x + +mkpkg + This provides a package for creating an in-memory 2D bit array. + This can be used for large boolean masks with random access. It + is being added for use with pixel mask matching in world coordinates. + (1/9/08, Valdes) + +===== +V2.14 +===== + +fixpix/setfp.x + + This routine transforms the input mask values into the output mask + values. It allows the input mask to have two classes of bad pixels; + those which are interpolated and those which are not. + +fixpix/ytpmmap.x + Adds a procedure yt_mappm and internal argument to allow control of + the WCS matching of masks to images. The earlier versions always + matched masks using the physical coordinate system. Applications can + the new procedure to have some control over this. + (11/26/07, Valdes) + +t_txtcompile.x + +txtcompile + +mkpkg + This application compiles a text file into an SPP procedure that + can be called by the xt_txtopen procedure. The application is intended + to be used as a host preprocessing command in mkpkg files to support + things like host callable applications (e.g. see syshost). The + code is in xtools for savvy developers awaiting full integration. + (11/26/07, Valdes) + +xttxtfio.x + +mkpkg + The routines xt_txtopen and xt_txtclose follow the usual FIO + interface. They allow calling a procedure that sets a string file as + if it was a read-only file. (See the t_txtcompile.x procedure for a + way to create a procedure from a text file.) The file name for this + special case of a procedure uses the syntax "proc:NNNNNN" where NNNNNN + is the value returned by locpr. The application would construct this + name for the procedure it declares as extern. The intended purpose is + to allow building in configuration files, including a parameter file, + into a host callable executable where unsatisfied parameter values + default to a built-in file rather than issuing a prompt (see syshost). + When called with an actual file normal read-only FIO is used. + (11/26/07, Valdes) + +syshost.x + +mkpkg + This routine may be used by an application to set default + parameter values when the executable is called directly by the + host. The routine provides three files to search in order; two + keyword=value files and a par file. These files, primarily the + par file, may be encoded as compiled procedures (see txtcompile + and xt_txtopen/xt_txtclose) so that the binary can be distributed + without any configuration files. (11/26/07, Valdes) + +xtextns.x + Further restructuring of these routines to support binary tables. This + makes use the mef routines. (11/26/07, Valdes) + +===== +V2.13 +===== + +catquery/cqgfields.x + The documentation says that the offset field in the catalog description + file for simple text is the field number. However, the implementation + did not work this way. The changes makes the catalog parsing work as + described. (7/17/07, Valdes) + +xtextns.x + +doc/xtextns.hlp + +doc/xtools.hd +mkpkg + Routines for expanding MEF image extensions. The first version of + this functionality was developed for proto.imextensions and then + expanded for mscred.mscextensions. Since then these routines have + been used in other tasks and so these are now being escalated to + generic xtools routines. (3/20/07, Valdes) + +xtmaskname.x +doc/xtmaskname.hlp + +doc/xtools.hd + The case where masktype=pl and the input name doesn't have a .pl + extension was wrong. (3/19/07, Valdes) + +fixpix/ytfixpix.x + + This version uses an internal copy of the input mask rather than + modifying the input mask. (3/19/07, Valdes) + +fixpix/xtpmmap.x +fixpix/ytpmmap.x + +fixpix/mkpkg +doc/xtpmmap.hlp + +doc/xtools.hd + 1. Uses xt_maskname to handle mask names. + 2. Minor bug fixes. + 3. The xt_ and yt_ versions are the same but the yt_version is + present to allow external packages to check for the presence + of ytpmmap.x and if not present use their own copy of the file. + This allows these packages to be compiled with earlier versions. + Eventually the yt versions should be obsoleted. + (3/19/07, Valdes) + +xtargs.x + +mkpkg + Simple interface to parse an argument string consisting of a list + of whitespace separated keyword=value pairs. (8/31/05, Valdes) + +======= +V2.12.3 +======= + +rmsorted.x +lib$pkg/rmsorted.h + This implements a sorted running median algorithm. + (5/12/05, Valdes) + +rmturlach.x + This implements the Turlach running median algorithm from the R package. + (5/12/05, Valdes) + +xtsample.gx + Utility to get a sample of pixels from an image. (5/6/05, Valdes) + +xtstat.gx + Utility to compute a mean, sigma, median, and mode. This is commonly + used with xt_sample. (5/6/05, Valdes) + +fixpix/xtfp.x + Wrong fix was made. (1/4/05, Valdes) + +fixpix/xtfp.x + For reasons I can't understand, the column interpolation was broken. + A loop over the columns was using ncols=FP_NCOLS, the number of bad pixels + across columns, instead of nc=IM_LEN(im,1), the number of columns in + the image. + (6/22/04, Valdes) + +numrecipes.x + Added LU decomposition. (6/18/04, 2004) + +fixpix/xtpmmap.x + 1. The routines now allow selecting whether to match masks in physical + coordinates or logical coordinates. When matching in logical + coordinates this simply means extending or trimming the mask if + the sizes are not the same. + 2. Added a new routine xt_mappm which is now the prefered routine + that allows selecting the matching type. The previous xt_pmmap + could not be changed since it used by various tasks. + (6/18/04, Valdes) + +xtmasknames.x + Added routines that hand pixel mask names. This is fairly sophisticated + in dealing with whether or not the user specifies file extensions, + image extensions, and flags. It will produced masks in FITS extensions + by default. (6/16/04, Valdes) + +======= +V2.12.2 +======= + +fixpix/xtpmmap.x + If the mask and data are offset by a fraction of a pixel it was possible + to get an out-of-bounds error. (8/14/03, Valdes) + +fixpix/xtpmmap.x + The loop over the range list in xt_match should start at 2 rather + than 1. (8/14/03, Valdes) + +fixpix/xtpmmap.x + Added some error checks to avoid a segmentation violation in xt_pmtext + when there is an error in im_pmmapo. (9/16/02, Valdes) + +fixpix/xtpmmap.x + A common case of matching a mask to an image is where the pixel sizes + are the same but there are offsets and/or different sizes. An optimized + mask matching based on using range lists and not calling mwcs was + added. (9/12/02, Valdes) + +fixpix/xtpmmap.x + Added test for a pm pointer in xt_pmmap. I can't remember why this + is was added in the version in ACE but it seems right. (9/10/02, Valdes) + +fixpix/xtpmmap.x + In the mask matching if there is no offset or sampling difference it + was returning the mask unchanged even if the sizes are not the same. + (9/10/02, Valdes) + +======= +V2.12.1 +======= + +===== +V2.12 +===== + +xtools$fixpix/xtpmmap.x + The change to IMIO for mapping bad pixel files in FITS extensions + resulted in a different error code when failing to open the file. + This code needed to be recognized by this routine in order to + continue on to try other possible formats. (2/27/02, Valdes) + +xtools$rngranges.x + Further modification for INDEF range limits. (2/4/02, Valdes) + +xtools$rngranges.x + Added missing rstr argument to 2 rng_error calls. (01/07/02, Davis) + +xtools$catquery/cqquery.x + Fixed a couple of typos in the code which detects the end of the http + header. (01/03/02, Davis) + +xtools$rngranges.x +xtools$rngranges.xBAK + + Modified rng_add to handle INDEFs better. This was the change found + in the nmisc version. There are some other differences but since the + records of why the changes were made are missing I fixed only the + immediate problem found with OBSUTIL.SPECFOCUS. + (11/14/01, Valdes) + +xtools$skywcs/doc/skdecim.hlp +xtools$skywcs/doc/skequatorial.hlp +xtools$skywcs/doc/sklltran.hlp +xtools$skywcs/doc/skultran.hlp +xtools$skywcs/doc/skywcs.hlp +xtools$catquery/doc/catquery.hlp +xtools$catquery/doc/cqsqpar.hlp +xtools$catquery/doc/cqsqparn.hlp + Fixed various formatting problems in the skywcs and catquery library + help pages. (19/09/01, Davis) + +xtools$catquery/ + Added the prototype catalog and survey access tools to the xtools package. + (27/08/01, Davis) + +xtools$fixpix/xtpmmap.x + Added missing argument to mw_ctrand calls. (6/15/01, Valdes) + +xtools$fixpix/xtpmmap.x + Fixed problems with xt_match. The new version is more robust and + correct. A bad pixel for the reference image is the maximum of all + pixels in the pixel mask which fall within the reference pixel. This + version still does not allow any relative rotations but does allow + non-integer offsets. (4/24/01, Valdes) + +xtools$fixpix/xtfixpix.x + Added a call to pm_compress to compress the pixel mask if there are + more than a certain number of edits to avoid the memory inefficiency + in plio. (2/2/01, Valdes) + +xtools$fixpix/xtpmmap.x + A mask name beginning with '^' is used to invert a mask. + (2/1/01, Valdes) + +xtools$inlfit.gx +xtools$inlfitr.x +xtools$inlfitd.x +xtools$inlrefit.gx +xtools$inlreffitr.x +xtools$inlrefitd.x + Added a check for the condition case where the number of data points + minus the number of deleted points (i.e. those with weights of 0.0) + is less than the number of fitting parameters. The previous checks did + not task into account the number of deleted points and could produce + solutions that were correct but non-physical (1/2/01, Davis) + +xtools$fixpix/xtpmmap.x + 1. The test for matching offsets was incorrect. + 2. The use of BPM was broken. + 3. There was a memory leak because imunmap does not free the pl + pointer set with im_pmmapo (also there was an imio bug in + freeing the pl pointer set with im_pmmap which has now been + fixed). A new procedure xt_pmunmap should be used whenever + xt_pmmap is used to insure any internal pointer created by + xt_match to match the mask to a reference image is freed. + (12/12/00, Valdes) + +xtools$skywcs/ + Added the sky coordinates transformation tools to the xtools package. + (10/12/00, Davis) + +========= +V2.11.3p1 +========= + +xtools/fixpix/xtpmmap.x + A mask name begining with '!' is now treated as a reference to a + header keyword. (9/4/00, Valdes) + +xtools/fixpix/xtpmmap.x + When a pixel mask (overlay or bad pixel) needed to be matched to + the data in physical coordinates the internal generation of a + new mask was being done in short integers. This would truncate + any masks with values greater than 16 bits. All uses of short + where changed to integer. (5/16/00, Valdes) + +========= +V2.11.3p1 +========= + +======= +V2.11.3 +======= + +xtools$fixpix/xtfp.gx + The formating of the verbose pixel printing was missing a couple of + blanks. (12/15/99, Valdes) + +======= +V2.11.2 +======= + +xtools$ranges/mkpkg +xtools$icfit/mkpkg +xtools$fixpix/mkpkg +xtools$mkpkg + Added missing dependencies. (10/11/99, Valdes) + +xtools$inlfit/mkpkg + Removed an uncessary file dependency from the mkpkg file. (20/9/99, Davis) + +======= +V2.11.2 +======= +xtools$fixpix/xtpmmap.x + Removed extra argument to imgl1i. (8/11/99, Valdes) + +xtools$imtools.x + fnext is a function not a subroutine. (8/11/99, Valdes) + +xtools$xtanswer.x + Fixed incorrect number of arguments in getline call. (8/11/99, Valdes) + +xtools$nlfit/inreject.x +xtools$nlfit/inrejectr.x +xtools$nlfit/inrejectd.x + Rearranged the code to remove a missing sfree statement problem + detected by spplint. (8/10/99, Davis) + +xtools$center1d.x + The step of finding a local maxima was not correct. (4/19/99, Valdes) + +xtools$fixpix/xtfp.gx + If there was no column interpolation the pixel type for the allocated + data array was not set resulting in an error during xt_fpfree. + (7/20/98, Valdes) + +xtools$%xtimnames.x + Modified extension testing code to use iki_validextn. + (7/13/98, Valdes) + +xtools$fixpix/xtfp.gx + Fixed a bug allowing out-of-bounds reference to FP_COL. + (6/6/98, Valdes) + +xtools$fixpix/xtpmmap.x + The steps to check if an image and mask have an integer relationship + (integer sampling and integer offsets) in their physical coordinate + systems could fail because real precision was not high enough + in MWCS transformation calls. Changed variables and MWCS calls + to double. (5/29/98, Valdes) + +xtools$fixpix/xtpmmap.x + The XT_PMINVERT function has a bug in using the range list. + (4/22/98, Valdes) + +xtools$fixpix/xtfixpix.h +xtools$fixpix/xtfixpix.x +xtools$fixpix/xtfp.gx + The modified data buffer returned by xt_fps$t used the imgl2$t buffer + which might be invalidated by subsequent imio activity such as + impl2$t. This was found with proto.fixpix. The routines were modified + to allocate and use a separate line buffer. Note that this only + applies to lines which are modified. If the requested line does + not have any bad pixels to fix then the input buffer is still returned. + (1/29/98, Valdes) + +xtools$fixpix/xtfp.gx + When a segment of bad pixels contains a mixture of column and line + interpolations and the first pixel is column interpolation then the + line interpolations could be wrong because interpolation coefficients are + not initialized. A second minor fix is that the column interpolation + endpoints printed in pixel listing mode could be incorrect. + (1/29/98, Valdes) + +======= +V2.11.1 +======= + +xtools$imtools.x + XT_MKIMTEMP was modified to append the same extension as the input + image when creating a temporary image name. (10/30/97, Valdes) + +xtools$ranges.x + Returned the EOLIST marker to zero since some programs rely on this. + This means that zero cannot be a range element. Added some + checks against a zero step size. (8/22/97, Valdes) + +xtools$fixpix/xtpmmap.x + There was a bug in the code which gives "Warning: PLIO: reference out + of bounds on mask". This was introduced with the changes to allow + masks and images to have different binning. (8/21/97, Valdes) + +xtools$ranges.x +xtools$doc/ranges.hlp + Now allows zero as a valid range element though the default for a + null string is still 1. (7/15/97, Valdes) + +========= +V2.11Beta +========= + +xtools$fixpix/xtpmmap.x + Improved xt_match to match when the sampling is different. + (5/21/97, Valdes) + +xtools$obsdb.x + File date was changed but the code was not changed (5/7/97, Valdes) + +xtools$dttext.x + Added the new routine dtgetd to the dttext package. (1/16/97, Davis) + +xtools$fixpix/xtpmmap.x + Fixed some bugs. (12/30/96, Valdes) + +xtools$mkpkg +xtools$fixpix/ + + Added some new tools for dealing with masks. (12/6/96, Valdes) + +xtools$center1d.x + When the width parameter is less than or equal to 1 pixel the algorithm + is supposed to return the nearest local maximum. There was a bug + such that the nearest pixel to the starting point was returned + unless that pixel is a local minimum. (10/24/96, Valdes) + +xtools$numrecipes.x + Modified the Poisson deviate routine to return zero for input + values less than or equal to zero. (10/1/96, Valdes) + +xtools$xtimnames.x + Added "fits" and "fit" as extensions. (7/30/96, Valdes) + +xtools$inlfit/ingresults.gx + Changed several INDEFR references to INDEF references so that INDEF + has the correct type (real or double) in the output .x files. + (18/7/96, Davis) + +xtools$dttext.x + The dtunmap procedure now returns if a null pointer is received. + (1/6/95, Valdes) + +xtools$center1d.x + Added a routine that allows setting some of the previously hardwired + parameters. By default the routines behave as before unless + c1d_params is called to set the parameters. (10/2/95, Valdes) + +xtools$incopy.gx + Changed 4 MEMP references to Mem$t references. The in_copyr and + in_copyd routines are not used anywhere in the system so this should + not be a problem. (8/2/95, Davis) + +xtools$rngranges.x + Added missing argument to rng_error calls. (8/2/95, Valdes) + +======= +V2.10.4 +======= + +xtools$obsdb.x + Changed the "timezone" parameter to be a double instead of an integer. + There are non-integer timezones such as India. (12/29/94, Valdes) + +xtools$numrecipes.x + The POIDEV routine can still have a problem in that the tan function + can return a very large number triggering either an overflow in + the evaluation of em or in the int truncation of em as addressed + below. A test is now made on the value of the tan function. + (9/14/94, Valdes) + +xtools$numrecipes.x + The POIDEV routine from Numerical Recipes can try to coerce a large + floating point number to an integer which can cause an exception. + If the value is 100 or greater a Gaussian deviate is now returned. + (8/11/93, Valdes) + +============ +V2.10.3 beta +============ + +xtools$center1d.x + For EMISSION features the threshold is applied as an absolute threshold + if the minimum data value is above zero and as a threshold relative to the + minimum data value if the minimum data value is below zero. Without + this change centering would fail if the data was all below zero. + (5/5/93, Valdes) + +xtools$obsdb.x + Fixed a couple of typos in comments. No code changes. (4/28/93, Valdes) + +xtools$rngranges.x + Yet another ranges package. This ranges package allows real number + ranges (including negative values) and @ lists. It is an object + oriented package using a pointer. + + RNG_OPEN -- Open a range string. Return a pointer to the ranges. + RNG_CLOSE -- Close range structure. + RNG_INDEX -- Get ith range element. Return EOF if index is out of range. + RNG_NEAREST -- Get nearest range index and value to input value. + Return the difference. + RNG_INRANGER -- Check if real value is within a range. + RNG_INRANGEI -- Check if integer value is within a range. + RNG_ELEMENTR -- Check if real value is an element. + RNG_ELEMENTI -- Check if integer value is an element. + RNG_ADD -- Add a range. + RNG_ERROR -- Set error flag and free memory. + (2/16/93, Valdes) + +xtools$center1d.x + If the initial center was more than three pixels from the true center + the interation would stop prematurely because of the dxcheck criterion. + Changed dxabs to be the full dx rather than the the limit of 1 pixel + per interation. This allows the interation to step as often as + it needs in one pixel steps until the dx estimate begins to become + small. It still preserves the checks for flipping back and forth + about the center and for a maximum number of times the dxabs + is greater than the previous minimum dxabs = dxlast. + (9/22/92, Valdes) + +======= +V2.10.2 +======= + +======= +V2.10.1 +======= + +lib$pkx/dttext.h +pkg$xtools/dttext.x + Added a new routine, dtremap, which allows keeping the database + open across multiple calls and remapping when a new database file + is specified. It is also optimized when switching back and forth + between read and append modes. The data structure was modified + to record the current database and file names for checking when + the name changes. (4/30/92, Valdes) + +pkg$xtools/obsdb.x + 1. Removed obsimcheck procedure. Did not like the defaulting + to last set observatory if OBSERVAT not found. + 2. Added obsimopen procedure. This is the procedure to call when + dealing with images. It returns flags to determine whether a + new observatory was opened and whether the observatory was + define by the image header + 3. Added a verbose obsvopen to allow tracking what the interface is + doing. + 4. These changes made in conjunction with changes to the + astutil.observatory task. + (2/4/92, Valdes) + +pkg$xtools/xtimnames.x + + Added some tools for dealing with image kernel extensions in image names. + (1/22/92, Valdes) + +pkg$xtools/inlfit/infit.gx +pkg$xtools/inlfit/infitr.x +pkg$xtools/inlfit/infitd.x + The fit status was not being updated correctly if point were + automatically rejected from the fit as opposed to being deleted. + (1/8/92, Davis) + +pkg$numrecipes.x + Added some fourier routines. Note that this is still a source only + entry and is not part of libxtools. (9/4/91, Valdes for MJF) + +pkg$numrecipes.x + mr = 0.1 * mr --> mr = max (EPSILONR, 0.1 * mr) (9/2/91, Valdes) + +pkg$xtools/inlfit/ + The interactive non-linear least squares fitting package used by PHOTCAL + was installed in XTOOLS. (8/6/91) + +pkg$obsdb.x + + New observatory database routines. (11/6/90, Valdes) + +==== +V2.9 +==== + +pkg$xtools/center1d.x + In the case that the position correction flipped back and forth about the + center no center would be found. In this case I added a check to + divide the correction factor in half. (3/13/90, Valdes) + +pkg$xtools/numrecipes.x + + Add some procedures for generating Gaussian and Possion deviates + as well as an implementation of the Levenberg-Marquardt nonlinear + chi square minimization algorithm. These routines are either + direct implementations from Numerical Recipes or based on descriptions + in that book. (10/25/89, Valdes) + +pkg$xtools/dttext.x + Commented out the diagnostic message in dtlocate. (7/19/89, Valdes) + +pkg$xtools/center1d.x +pkg$xtools/doc/center1d.hlp + If the centering width is less than or equal to 1 the nearest minima or + maxima is found. As before, a minimum width of 3 is used if + the width is between 1 and 3. (7/13/89, Valdes) + +=========== +Version 2.8 +=========== + +pkg$xtools/logfiles.x + Added these routines to open and to close a list of logfiles. + (6/2/89, Seaman) + +pkg$xtools/ranges.x + Fixed a bunch of bugs in the zero handling, the MAX_INT handling and + that made the step notation flaky. Made a comma a hard separator + between two ranges rather than mere whitespace. (6/2/89, Seaman) + +pkg$xtools/xtmksections.x + A 2D image with second dimension length of 1 is returned without + an image section from xt_mk1d and xt_mksection. (1/31/89, Valdes) + +pkg$xtools/xtsort.x + Added a double precision version of the three vector sorter, named + xt_sort3d. It required a double precision version of xts_compared. + This change was to support the utilities.curfit task, which now + sorts its input list data before fitting. (6/24/88 ShJ) + +pkg$xtools/xtsums.x + When the number of lines or columns is 1 and the line or column is the + same as a previous call and a data is null then a new vector is not read + causing uninitialized data to be returned. Added l1=0 and c1=0 to fix + problem. This problem appeared in proto.toonedspec. (2/12/88 Valdes) + +pkg$xtools/mksection.x + User specified section strings of the form "column 051" are now + converted to [51,*] instead of [051,*]. (11/9/87 Valdes) + +==== +V2.5 +==== + +pkg$xtools/center1d.x +pkg$xtools/doc/center1d.hlp + Valdes, April 2, 1987: + 1. A bug with testing the right edge of the data was fixed. This caused + FPE errors on AOS/IRAF. + 2. The centering fails if the maximum number of iterations is reached + or the changes do not continue to decrease within 3 iterations of + the last minimum change. + 3. Defined parameters replaced constants used in the code. + +pkg$xtools/center1d.x +pkg$xtools/doc/center1d.hlp + Valdes, March 5, 1987: + 1. A silent minimum of 3 is imposed on the width parameter. If there + is ever a need to allow smaller widths then the procedure can + be changed and the application relinked. + 2. The help page was modified to reflect this change. + +pkg$xtools/center1d.x + Valdes, October 29, 1986: + 1. The first use of threshold was only as a data range limit. + Now it is used to eliminate all peaks less than threshold from + the continuum. This fixes ever finding weak features less + than threshold. + +pkg$xtools/center1d.x + Valdes, August 18, 1986: + 1. Added a detection threshold parameter to CENTER1D. + +==================================== +Version 2.3 Release, August 18, 1986 +==================================== + +cogetr.x: Valdes, July 3, 1986 + 1. Error in initializing the procedure cogetr fixed. + +icfit$: Valdes, July 3, 1986 + 1. ICFIT package replaced by a new version. + +===================================== +STScI Pre-release and SUN 2.3 release +===================================== + +icfit$icgfuncs.gx: Valdes, June 18, 1986 + 1. DCVEVAL was being called in ICGFUNCS with a real argument when + selecting the nonlinear plot (key 'l'). This caused an error + on the SUN. Changed "real" to PIXEL. + +gtools$gtwindow.x: Valdes, June 11, 1986 + 1. Added new procedure gt_window. It is a cursor driven procedure + for windowing graphs using the gtools pointer. The help + page for gtools was also modified to show the windowing options. + +gtools$gtcur.x: Valdes, May 10, 1986 + 1. Took out "Confirm:" prompt so that cursor input from a file does + not cause anything to be printed. Two EOF's (carriage return or + actual EOF) or a 'q' are required to exit thus protecting the user + from an inadvertent carriage return. + +imt.x: Valdes April 29, 1986 + 1. Modified the image template package to sort wildcard expansions. + +icfit$icgfit.gx,icgfit2.x,icgcolon.x: Valdes, April 7, 1986 + 1. Fixed use of STRIDX with a character constant to STRIDXS. + 2. Fixed problem with colon usage for ":sample" and ":function" + +xtools: Valdes, March 24, 1985 + 1. Added XT_PHISTORY to put dated history string. + +pkg$xtools/imtools.x: Valdes, March 18, 1985 + 1. XT_MKIMTEMP modified to create the temporary image header in the + user current directory with the prefix "tmp". + 2. XT_DELIMTEMP modified to call IMRENAME instead of RENAME. + +From Valdes March 13, 1986: + +1. Added procedure dtgad (database get array double) to dttext tools. +It's purpose is to accomodate double precisions curve fits. + +2. Added COGETR procedures for efficient column access. A help page +is available. + +3. Added XTSUMS procedures for buffered sums (both column and line). +They are particularly useful for moving sums type of operations. A help +page is available + +4. Added help pages for COGETR and XTSUMS procedures to help database. +------ +From Valdes March 10, 1986: + +1. Added IMTREW rewind procedure to image template tools. + +2. Added IMTGIM procedure to get an image from the template by index number. +------ +From Valdes March 5, 1986: + +1. Modified dttext to allow deleting a database. +=========== +Release 2.2 +=========== +From Valdes Feb. 8, 1986: + +1. Modified XT_DELIMTEMP and DEL_IMTEMP to update the pixel header +file so that it correctly points to the header file after the header +file is renamed. +------ +From Valdes Jan. 13, 1986: + +1. Changes in DTTEXT.X: + a. Size of OS filename in DTMAP1 extended from SZ_FNAME to + SZ_PATHNAME + SZ_FNAME. + b. Database directories do not allow periods in the names when + created. +2. XTMKSECTION was computing the middle line (or column) as +len / 2 which gave zero for an image of length 1. Changed to +(len + 1) / 2. +------ +From Valdes Dec. 31, 1985: + +1. A bug in imt.x due to incorrect indexing in a string has been fixed. +------ +From Valdes Nov. 22, 1985: + +1. A new procedure XT_GIDS has been added to find identifier tokens in a +string and match the identifiers against a dictionary string. An array +of YES/NO values for each dictionary entry, up to a maximum of maxids, +is returned. This procedure is useful for parsing an option string. +It is nice because identifiers can be abbreviated and delimiters can be +anything which is not an identifier token (whitespace, commas, colons, +semicolons, etc). +----- +From Valdes Nov. 15, 1985: + +1. Added DTMAP1 to DTTEXT.X text database package. This procedure +takes a directory name as the database and stores or access text database +files in the directory under the file name key. It maps the name +"database/key" and calls DTMAP. This allows better organization of +database information into subfiles of a database rather than one massive +text file. It calls DTMAP with the database name directly if the database +name is a regular file and not a directory. Thus, it is backwards +compatible with older single file text databases. + +2. Added ISDIRECTORY. This procedure tests a virtual file name to see +if it is a directory and returns the os pathname suitable for concatentation. +The function value is the number of characters in the pathname which is +0 for a nondirectory file. +cogetr.x: Valdes, July 3, 1986 + 1. Error in initializing the procedure cogetr fixed. + +icfit$: Valdes, July 3, 1986 + 1. ICFIT package replaced by a new version. + +===================================== +STScI Pre-release and SUN 2.3 release +===================================== + +icfit$icgfuncs.gx: Valdes, June 18, 1986 + 1. DCVEVAL was being called in ICGFUNCS with a real argument when + selecting the nonlinear plot (key 'l'). This caused an error + on the SUN. Changed "real" to PIXEL. + +gtools$gtwindow.x: Valdes, June 11, 1986 + 1. Added new procedure gt_window. It is a cursor driven procedure + for windowing graphs using the gtools pointer. The help + page for gtools was also modified to show the windowing options. + +gtools$gtcur.x: Valdes, May 10, 1986 + 1. Took out "Confirm:" prompt so that cursor input from a file does + not cause anything to be printed. Two EOF's (carriage return or + actual EOF) or a 'q' are required to exit thus protecting the user + from an inadvertent carriage return. + +imt.x: Valdes April 29, 1986 + 1. Modified the image template package to sort wildcard expansions. + +icfit$icgfit.gx,icgfit2.x,icgcolon.x: Valdes, April 7, 1986 + 1. Fixed use of STRIDX with a character constant to STRIDXS. + 2. Fixed problem with colon usage for ":sample" and ":function" + +xtools: Valdes, March 24, 1985 + 1. Added XT_PHISTORY to put dated history string. + +pkg$xtools/imtools.x: Valdes, March 18, 1985 + 1. XT_MKIMTEMP modified to create the temporary image header in the + user current directory with the prefix "tmp". + 2. XT_DELIMTEMP modified to call IMRENAME instead of RENAME. + +From Valdes March 13, 1986: + +1. Added procedure dtgad (database get array double) to dttext tools. +It's purpose is to accomodate double precisions curve fits. + +2. Added COGETR procedures for efficient column access. A help page +is available. + +3. Added XTSUMS procedures for buffered sums (both column and line). +They are particularly useful for moving sums type of operations. A help +page is available + +4. Added help pages for COGETR and XTSUMS procedures to help database. +------ +From Valdes March 10, 1986: + +1. Added IMTREW rewind procedure to image template tools. + +2. Added IMTGIM procedure to get an image from the template by index number. +------ +From Valdes March 5, 1986: + +1. Modified dttext to allow deleting a database. +=========== +Release 2.2 +=========== +From Valdes Feb. 8, 1986: + +1. Modified XT_DELIMTEMP and DEL_IMTEMP to update the pixel header +file so that it correctly points to the header file after the header +file is renamed. +------ +From Valdes Jan. 13, 1986: + +1. Changes in DTTEXT.X: + a. Size of OS filename in DTMAP1 extended from SZ_FNAME to + SZ_PATHNAME + SZ_FNAME. + b. Database directories do not allow periods in the names when + created. +2. XTMKSECTION was computing the middle line (or column) as +len / 2 which gave zero for an image of length 1. Changed to +(len + 1) / 2. +------ +From Valdes Dec. 31, 1985: + +1. A bug in imt.x due to incorrect indexing in a string has been fixed. +------ +From Valdes Nov. 22, 1985: + +1. A new procedure XT_GIDS has been added to find identifier tokens in a +string and match the identifiers against a dictionary string. An array +of YES/NO values for each dictionary entry, up to a maximum of maxids, +is returned. This procedure is useful for parsing an option string. +It is nice because identifiers can be abbreviated and delimiters can be +anything which is not an identifier token (whitespace, commas, colons, +semicolons, etc). +----- +From Valdes Nov. 15, 1985: + +1. Added DTMAP1 to DTTEXT.X text database package. This procedure +takes a directory name as the database and stores or access text database +files in the directory under the file name key. It maps the name +"database/key" and calls DTMAP. This allows better organization of +database information into subfiles of a database rather than one massive +text file. It calls DTMAP with the database name directly if the database +name is a regular file and not a directory. Thus, it is backwards +compatible with older single file text databases. + +2. Added ISDIRECTORY. This procedure tests a virtual file name to see +if it is a directory and returns the os pathname suitable for concatentation. +The function value is the number of characters in the pathname which is +0 for a nondirectory file. +.endhelp diff --git a/pkg/xtools/catquery/cq.h b/pkg/xtools/catquery/cq.h new file mode 100644 index 00000000..9d9f801f --- /dev/null +++ b/pkg/xtools/catquery/cq.h @@ -0,0 +1,100 @@ +# Public definitions file for the catalog query interface. + +# The catalog access interface parameter definitions + +define CQNRECS 1 # the number of records in the catalog database +define CQSZRECLIST 2 # the length of the record name list in chars +define CQRECLIST 3 # the record name @list +define CQCATDB 4 # the catalog database file name +define CQCATNO 5 # the current catalog record number +define CQCATNAME 6 # the current catalog name + +# The max size of a query parameter name, value, units, and formats string. + +define CQ_SZ_QPNAME 19 +define CQ_SZ_QPVALUE 79 +define CQ_SZ_QPUNITS 19 +define CQ_SZ_QPFMTS 11 + +# The maximum number of fields or columns in the result. + +define CQ_MAX_NFIELDS 100 + +# The catalog access results parameter definitions + +define CQRCATDB 1 # the catalog database file +define CQRCATNAME 2 # the catalog name +define CQRADDRESS 3 # the address +define CQRQUERY 4 # the query +define CQRNQPARS 5 # the number of query parameters +define CQRQPNAMES 6 # the query parameter names +define CQRQPVALUES 7 # the query parameter values +define CQRQPUNITS 8 # the query parameter units + +define CQRTYPE 9 # the results format (currently stext or btext) +define CQRECSIZE 10 # the record length in characters (default = 0) +define CQRHSKIP 11 # the number of header lines to skip (default = 0) +define CQRTSKIP 12 # the number of trailing lines to skip (default = 0) +define CQRTRIML 13 # the number of leading characters to trim +define CQRTRIMR 14 # the number of trailing characters to trim + +define CQRNRECS 15 # The number of records in the results +define CQNHEADER 16 # The number of header keywords in the results +define CQNFIELDS 17 # The number of record fields in the results +define CQRECPTR 18 # the current record pointer + +# The surveys access results parameter definitions + +define CQIMCATDB 1 +define CQIMCATNAME 2 +define CQIMADDRESS 3 +define CQIMQUERY 4 +define CQINQPARS 5 +define CQIQPNAMES 6 +define CQIQPVALUES 7 +define CQIQPUNITS 8 +define CQIMNAME 9 +define CQIMTYPE 10 +define CQWCS 11 +define CQNWCS 12 +define CQNIMPARS 13 + + +# The max size of a field name, value, units, and formats string. + +define CQ_SZ_FNAME 19 +define CQ_SZ_FVALUE 79 +define CQ_SZ_FUNITS 19 +define CQ_SZ_FFMTS 11 + + +# Define the default input catalog file types + +define CQ_RTYPESTR "|stext|btext|" + +define CQ_STEXT 1 # Simple text (free format fields) + # Newline delimited records + # Whitespace delimited fields + # No embedded whitespace unless in "" + # Skip nlines header + # Skip nchars at beginning / end of record + # Skip nlines trailer + + +define CQ_BTEXT 2 # Blocked text (fixed format fields) + # Fixed size newline delimited records + # Offset and size delimited fields + # Embedded whitespace permitted + # Skip nlines header + # Skip nchars at beginning / end of record + # Skip nlines trailer + + +define CQ_ITYPESTR "|fits|" +define CQ_FITS 1 + + +define CQ_WTYPESTR "|fits|dss|none|" +define CQ_WFITS 1 +define CQ_WDSS 2 +define CQ_WNONE 3 diff --git a/pkg/xtools/catquery/cqdb.x b/pkg/xtools/catquery/cqdb.x new file mode 100644 index 00000000..13434ca4 --- /dev/null +++ b/pkg/xtools/catquery/cqdb.x @@ -0,0 +1,442 @@ +include <ctype.h> +include "cqdef.h" +include "cq.h" + +# These are the catalog configuration file access routines used by the +# catalog access interface. These routines should not normally be called +# directly from the applications program. + + +# CQ_DGETI -- Get an integer field from the database record. + +int procedure cq_dgeti (cq, record, field) + +pointer cq #I The catalog database descriptor +int record #I The catalog record index +char field[ARB] #I The record field + +int ival #O Field value +char name[SZ_LINE] + +int fscan(), nscan() +bool streq() + +begin + if ((record < 1) || (record > CQ_NRECS(cq))) + call error (0, "The catalog record is out of bounds") + + call seek (CQ_FD(cq), CQ_OFFSET(cq, record)) + + while (fscan (CQ_FD(cq)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargi (ival) + if (nscan() == 2) + return (ival) + else + call error (0, "Error reading catalog integer field value") + } + } + + call error (0, "Catalog record field not found") +end + + +# CQ_DGETR -- Get a real field from the catalog database record. + +real procedure cq_dgetr (cq, record, field) + +pointer cq #I The catalog database descriptor +int record #I The catalog database record index +char field[ARB] #I The catalog record field + +real rval +char name[SZ_LINE] + +int fscan(), nscan() +bool streq() + +begin + if ((record < 1) || (record > CQ_NRECS(cq))) + call error (0, "The catalog record is out of bounds") + + call seek (CQ_FD(cq), CQ_OFFSET(cq, record)) + + while (fscan (CQ_FD(cq)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargr (rval) + if (nscan() == 2) + return (rval) + else + call error (0, "Error reading real catalog field value") + } + } + + call error (0, "Catalog record field not found") +end + + +# CQ_DGETD -- Get a double precision field from a record. + +double procedure cq_dgetd (cq, record, field) + +pointer cq #I The catalog database descriptor +int record #I The catalog database index +char field[ARB] #I The catalog database field + +double dval +char name[SZ_LINE] + +int fscan(), nscan() +bool streq() + +begin + if ((record < 1) || (record > CQ_NRECS(cq))) + call error (0, "The catalog record is out of bounds") + + call seek (CQ_FD(cq), CQ_OFFSET(cq, record)) + + while (fscan (CQ_FD(cq)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargd (dval) + if (nscan() == 2) + return (dval) + else + call error (0, "Error reading double catalog field value") + } + } + + call error (0, "Catalog record field not found") +end + + +# CQ_DGWRD -- Get a string field from the database file. + +procedure cq_dgwrd (cq, record, field, str, maxchar) + +pointer cq #I The catalog access descriptor +int record #I The catalog record index +char field[ARB] #I The field name +char str[maxchar] #O The output string value +int maxchar #I The maximum characters for string + +char name[SZ_LINE] +int i, fscan() +bool streq() + +begin + if ((record < 1) || (record > CQ_NRECS(cq))) + call error (0, "Catalog record is out of bounds") + + call seek (CQ_FD(cq), CQ_OFFSET(cq, record)) + + while (fscan (CQ_FD(cq)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargwrd (str, maxchar) + for (i=1; IS_WHITE(str[i]); i=i+1) + ; + if (i > 1) + call strcpy (str[i], str, maxchar) + return + } + } + + call error (0, "Catalog record field not found") +end + + +# CQ_DGSTR -- Get a string field from the database file. + +procedure cq_dgstr (cq, record, field, str, maxchar) + +pointer cq #I The catalog access descriptor +int record #I The catalog record index +char field[ARB] #I The field name +char str[maxchar] #O The output string value +int maxchar #I The maximum characters for string + +char name[SZ_LINE] +int i, fscan() +bool streq() + +begin + if ((record < 1) || (record > CQ_NRECS(cq))) + call error (0, "Catalog record is out of bounds") + + call seek (CQ_FD(cq), CQ_OFFSET(cq, record)) + + while (fscan (CQ_FD(cq)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargstr (str, maxchar) + for (i=1; IS_WHITE(str[i]); i=i+1) + ; + if (i > 1) + call strcpy (str[i], str, maxchar) + return + } + } + + call error (0, "Catalog record field not found") +end + + +# CQ_DGAI -- Get an integer array field from a record. + +procedure cq_dgai (cq, record, field, array, len_array, npts) + +pointer cq #I The database catalog record +int record #I The database record index +char field[ARB] #I The database field +int array[len_array] #O The output array values +int len_array #I The length of array +int npts #O The number of points in the array + +char name[SZ_LINE] +int i + +int fscan(), nscan() +bool streq() + +begin + if ((record < 1) || (record > CQ_NRECS(cq))) + call error (0, "The catalog record is out of bounds") + + call seek (CQ_FD(cq), CQ_OFFSET(cq, record)) + + while (fscan (CQ_FD(cq)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargi (npts) + if (nscan() != 2) + call error (0, "Error reading size of integer array") + + npts = min (npts, len_array) + for (i = 1; i <= npts; i = i + 1) { + if (fscan (CQ_FD(cq)) == EOF) + call error (0, "The integer array is truncated") + + call gargi (array[i]) + if (nscan() != 1) + call error (0, "Error decoding integer array") + } + return + } + } + + call error (0, "The catalog record field not found") +end + + +# CQ_DGAR -- Get a real array field from a record. + +procedure cq_dgar (cq, record, field, array, len_array, npts) + +pointer cq #I The database catalog record +int record #I The database record index +char field[ARB] #I The database field +real array[len_array] #O The output array values +int len_array #I The length of array +int npts #O The number of points in the array + +char name[SZ_LINE] +int i + +int fscan(), nscan() +bool streq() + +begin + if ((record < 1) || (record > CQ_NRECS(cq))) + call error (0, "The catalog record is out of bounds") + + call seek (CQ_FD(cq), CQ_OFFSET(cq, record)) + + while (fscan (CQ_FD(cq)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargi (npts) + if (nscan() != 2) + call error (0, "Error reading real array size value") + + npts = min (npts, len_array) + for (i = 1; i <= npts; i = i + 1) { + if (fscan (CQ_FD(cq)) == EOF) + call error (0, "The real array is truncated") + + call gargr (array[i]) + if (nscan() != 1) + call error (0, "Error reading real array") + } + return + } + } + + call error (0, "The catalog record field not found") +end + + +# CQ_DGAD -- Get a double array field from a catalog. + +procedure cq_dgad (cq, record, field, array, len_array, npts) + +pointer cq #I The catalog database descriptor +int record #I The catalog record index +char field[ARB] #I The database field +double array[len_array] #O The array values +int len_array #I The length of array +int npts #O The number of points in the array + +char name[SZ_LINE] +int i + +int fscan(), nscan() +bool streq() + +begin + if ((record < 1) || (record > CQ_NRECS(cq))) + call error (0, "The catalog record is out of bounds") + + call seek (CQ_FD(cq), CQ_OFFSET(cq, record)) + + while (fscan (CQ_FD(cq)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargi (npts) + if (nscan() != 2) + call error (0, "Error the double array size") + + npts = min (npts, len_array) + for (i = 1; i <= npts; i = i + 1) { + if (fscan (CQ_FD(cq)) == EOF) + call error (0, "The double array is truncated") + + call gargd (array[i]) + if (nscan() != 1) + call error (0, "Error reading the double array") + } + return + } + } + + call error (0, "Catalog record field not found") +end + + +# CQ_DGATXT -- Get newline delimited text from a database file. + +procedure cq_dgatxt (cq, record, field, str, maxchar, nlines) + +pointer cq #I The catalog access descriptor +int record #I The catalog record index +char field[ARB] #I The field name +char str[maxchar] #O The output string value +int maxchar #I The maximum characters for string +int nlines #I the number of text lines + +char name[SZ_LINE] +int i, op +int fscan(), nscan(), gstrcpy() +bool streq() + +begin + if ((record < 1) || (record > CQ_NRECS(cq))) + call error (0, "Catalog record is out of bounds") + + call seek (CQ_FD(cq), CQ_OFFSET(cq, record)) + + while (fscan (CQ_FD(cq)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargi (nlines) + if (nscan() != 2) + call error (0, "Error text array length") + op = 1 + do i = 1, nlines { + if (fscan (CQ_FD(cq)) == EOF) + call error (0, "The text array is truncated") + call gargstr (name, SZ_LINE) + op = op + gstrcpy (name, str[op], maxchar - op +1) + if (op > maxchar) + break + str[op] = '\n' + op = op + 1 + str[op] = EOS + } + + return + } + } + + call error (0, "Catalog record field not found") +end + + +## DTPTIME -- Put a time string with a comment +# +#procedure dtptime (dt) +# +#pointer dt # DTTEXT pointer +# +#char timestr[SZ_TIME] +#long time, clktime() +# +#begin +# time = clktime (0) +# call cnvtime (time, timestr, SZ_TIME) +# call fprintf (DT(dt), "# %s\n") +# call pargstr (timestr) +#end +# +# +## DTPUT -- Print to database. +# +#procedure dtput (dt, format) +# +#pointer dt # DTTEXT pointer +#char format[ARB] # String format +# +#begin +# call fprintf (DT(dt), format) +#end + +# CQ_DSCAN -- Scan database. + +int procedure cq_dscan (cq) + +pointer cq # The catalog database descriptor. + +int fscan() + +begin + return (fscan (CQ_FD(cq))) +end diff --git a/pkg/xtools/catquery/cqdef.h b/pkg/xtools/catquery/cqdef.h new file mode 100644 index 00000000..6337bd9f --- /dev/null +++ b/pkg/xtools/catquery/cqdef.h @@ -0,0 +1,133 @@ +# Private definitions file for the catalog query interface. + + +# Miscellaneous definitions mostly concerning buffer sizes. + +#define CQ_SZ_LINE SZ_LINE # The text storage size in chars +define CQ_SZFNAME (1+SZ_FNAME) / 2 # The file name storage size in structs +define CQ_SZLINE (1+SZ_LINE) / 2 # The text storage size in structs +define CQ_ALLOC 20 # The record allocation block size + +define USE_URLGET TRUE + + +# The catalog record map descriptor (borrowed from dttext interface). + +define CQ_LEN (8 + 2 * CQ_SZFNAME) + +define CQ_FD Memi[$1] # The database FIO channel +define CQ_MODE Memi[$1+1] # The database access mode +define CQ_NRECS Memi[$1+2] # The number of records +define CQ_MAP Memi[$1+3] # The pointer to record names +define CQ_NAMES Memi[$1+4] # The pointer to name indices +define CQ_OFFSETS Memi[$1+5] # The pointer to record offsets +define CQ_CATNO Memi[$1+6] # The current catalog number +define CQ_CAT Memi[$1+7] # The current catalog descriptor +define CQ_CATDB Memc[P2C($1+8)] # The database file name +define CQ_CATNAME Memc[P2C($1+8+CQ_SZFNAME)]# The current catalog name + +define CQ_NAMEI Memi[CQ_NAMES($1)+$2-1] +define CQ_NAME Memc[CQ_MAP($1)+CQ_NAMEI($1,$2)] +define CQ_OFFSET Meml[CQ_OFFSETS($1)+$2-1] + + +# The current catalog desciptor. + +define CQ_LEN_CC (15 + 2 * CQ_SZLINE) +define QOFFSET P2C($1+15+$2*CQ_SZLINE) + +define CQ_NQPARS Memi[$1] # The no of query params +define CQ_PQPNAMES Memi[$1+1] # The query param names ptr +define CQ_PQPDVALUES Memi[$1+2] # The query param defaults ptr +define CQ_PQPVALUES Memi[$1+3] # The query param values ptr +define CQ_PQPUNITS Memi[$1+4] # The query param units ptr +define CQ_PQPFMTS Memi[$1+5] # The query param format ptr +define CQ_HFMT Memi[$1+6] # The header format +define CQ_ADDRESS Memc[QOFFSET($1,0)] # The catalog address +define CQ_QUERY Memc[QOFFSET($1,1)] # The network query + +# The catalog results descriptor. + +define CQ_LEN_RES (30+2*CQ_SZFNAME+2*CQ_SZLINE) +define ROFFSET P2C($1+30+$2*CQ_SZFNAME+$3*CQ_SZLINE) + +define CQ_RNQPARS Memi[$1] # The number of query params +define CQ_RQPNAMES Memi[$1+1] # The query param names ptr +define CQ_RQPVALUES Memi[$1+2] # The query param values ptr +define CQ_RQPUNITS Memi[$1+3] # The query param units ptr + +define CQ_RTYPE Memi[$1+4] # The results data format +define CQ_RECSIZE Memi[$1+5] # The results record size +define CQ_RHSKIP Memi[$1+6] # The number of header records to skip +define CQ_RTRIML Memi[$1+7] # The beginning of record trim +define CQ_RTRIMR Memi[$1+8] # The end of record trim +define CQ_RTSKIP Memi[$1+9] # The number of trailer records to skip + +define CQ_NHEADER Memi[$1+10] # The number of header keywords +define CQ_HKNAMES Memi[$1+11] # The results keyword names +define CQ_HKVALUES Memi[$1+12] # The result keyword values + +define CQ_NFIELDS Memi[$1+13] # The number of record fields +define CQ_FNAMES Memi[$1+14] # The record field names +define CQ_FTYPES Memi[$1+15] # The record field data types ptr +define CQ_FOFFSETS Memi[$1+16] # The record field offsets ptr +define CQ_FSIZES Memi[$1+17] # The record field sizes ptr +define CQ_FUNITS Memi[$1+18] # The record field units +define CQ_FFMTS Memi[$1+19] # The record field formats + +define CQ_RFD Memi[$1+20] # The results file descriptor +define CQ_RBUF Memi[$1+21] # The results data descriptor +define CQ_RNRECS Memi[$1+22] # The number of results records +define CQ_RINDEX Memi[$1+23] # The results record index pointer + +define CQ_RECPTR Memi[$1+24] # The current record +define CQ_FNFIELDS Memi[$1+25] # The number of fields in current record +define CQ_FINDICES Memi[$1+26] # The current record indices pointer + +define CQ_RCATDB Memc[ROFFSET($1,0,0)] # The catalog database name +define CQ_RCATNAME Memc[ROFFSET($1,1,0)] # The catalog name + +define CQ_RADDRESS Memc[ROFFSET($1,2,0)] # Query address +define CQ_RQUERY Memc[ROFFSET($1,2,1)] # Query string + +# The image survey descriptor. May need to extend this structure as more +# experience with different image formats is obtained. May not need wcs and +# keyword default value strings ... + +define CQ_LEN_IM (30+3*CQ_SZFNAME+2*CQ_SZLINE) +define IOFFSET P2C($1+30+$2*CQ_SZFNAME+$3*CQ_SZLINE) + +define CQ_INQPARS Memi[$1] # The number of query params +define CQ_IQPNAMES Memi[$1+1] # The query param names ptr +define CQ_IQPVALUES Memi[$1+2] # The query param values ptr +define CQ_IQPUNITS Memi[$1+3] # The query param units ptr +define CQ_IMTYPE Memi[$1+4] # The image data format + +define CQ_WCS Memi[$1+10] # The image wcs type +define CQ_NWCS Memi[$1+11] # The number of wcs keywords +define CQ_WPNAMES Memi[$1+12] # The wcs parameter names +define CQ_WKNAMES Memi[$1+13] # The wcs keyword names +define CQ_WKDVALUES Memi[$1+14] # The wcs keyword default values +define CQ_WKVALUES Memi[$1+15] # The wcs keyword values +define CQ_WKTYPES Memi[$1+16] # The wcs keyword data types +define CQ_WKUNITS Memi[$1+17] # The wcs keyword value units + +define CQ_NIMPARS Memi[$1+19] # The number of header keywords +define CQ_IPNAMES Memi[$1+20] # The results keyword names +define CQ_IKNAMES Memi[$1+21] # The result keyword values +define CQ_IKDVALUES Memi[$1+22] # The result keyword values +define CQ_IKVALUES Memi[$1+23] # The result keyword values +define CQ_IKTYPES Memi[$1+24] # The result keyword values +define CQ_IKUNITS Memi[$1+25] # The result keyword values + +define CQ_IMCATDB Memc[IOFFSET($1,0,0)] # The survey database name +define CQ_IMCATNAME Memc[IOFFSET($1,1,0)] # The survey name +define CQ_IMNAME Memc[IOFFSET($1,2,0)] # The image name + +define CQ_IMADDRESS Memc[IOFFSET($1,3,0)] # Query address +define CQ_IMQUERY Memc[IOFFSET($1,3,1)] # Query string + + +define CQ_HFMTSTR "|none|http|" +define CQ_HNONE 1 +define CQ_HHTTP 2 diff --git a/pkg/xtools/catquery/cqdtype.x b/pkg/xtools/catquery/cqdtype.x new file mode 100644 index 00000000..e0088590 --- /dev/null +++ b/pkg/xtools/catquery/cqdtype.x @@ -0,0 +1,53 @@ +# CQ_DTYPE -- Decode the field data type. + +define NTYPES 6 + +# CQ_DTYPE -- Given a single character data type from the set [csilrd] return +# the appropriate integer type, + +int procedure cq_dtype (c) + +char c + +int type_codes[NTYPES], i +string types "csilrd" +int stridx() +data type_codes /TY_CHAR, TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE/ +begin + i = stridx (c, types) + if (i == 0) + return (TY_CHAR) + else + return (type_codes[stridx(c,types)]) +end + +# CQ_ITYPE -- Given an integer code from the set TY_CHAR, TY_SHORT, TY_INT, +# TY_LONG, TY_REAL, and TY_DOUBLE return the appropriate character code +# from the set [csilrd]. + +char procedure cq_itype (itype) + +int itype #I the integer data type + +char c + +begin + switch (itype) { + case TY_CHAR: + c = 'c' + case TY_SHORT: + c = 's' + case TY_INT: + c = 'i' + case TY_LONG: + c = 'l' + case TY_REAL: + c = 'r' + case TY_DOUBLE: + c = 'd' + default: + c = 'c' + } + + return (c) +end diff --git a/pkg/xtools/catquery/cqget.x b/pkg/xtools/catquery/cqget.x new file mode 100644 index 00000000..ea259bb5 --- /dev/null +++ b/pkg/xtools/catquery/cqget.x @@ -0,0 +1,225 @@ +include "cqdef.h" +include "cq.h" + +# These routines fetch fields from the catalog configuation by field name. +# They can be used by the calling program to read quantities of interest +# directly from the configuration file. In most applications it should +# not be necessary to use these routines as the main interface routines +# provide most of the desired functionality, but they are included for +# completeness. + +# CQ_FGETI -- Fetch an integer field from the current catalog. + +int procedure cq_fgeti (cq, field) + +pointer cq #I the catalog descriptor +char field[ARB] #I the field name + +int ival +int cq_dgeti() +errchk cq_dgeti() + +begin + if (CQ_CAT(cq) == NULL) + call error (0, "The current catalog is undefined") + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + call error (0, "The current catalog is undefined") + + ival = cq_dgeti (cq, CQ_CATNO(cq), field) + + return (ival) +end + + +# CQ_FGETR -- Fetch a real field from the current catalog. + +real procedure cq_fgetr (cq, field) + +pointer cq #I the catalog descriptor +char field[ARB] #I the field name + +real rval +real cq_dgetr() +errchk cq_dgetr() + +begin + if (CQ_CAT(cq) == NULL) + call error (0, "The current catalog is undefined") + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + call error (0, "The current catalog is undefined") + + rval = cq_dgetr (cq, CQ_CATNO(cq), field) + + return (rval) +end + + +# CQ_FGETD -- Fetch a double precision field from the current catalog. + +double procedure cq_fgetd (cq, field) + +pointer cq #I the catalog descriptor +char field[ARB] #I the field name + +double dval +double cq_dgetd() +errchk cq_dgetd() + +begin + if (CQ_CAT(cq) == NULL) + call error (0, "The current catalog is undefined") + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + call error (0, "The current catalog is undefined") + + dval = cq_dgetd (cq, CQ_CATNO(cq), field) + + return (dval) +end + + +# CQ_FGAI -- Get an array valued integer parameter. + +int procedure cq_fgai (cq, field, array, max_len) + +pointer cq #I the catalog descriptor +char field[ARB] #I the field name +int array[ARB] #O the output array +int max_len #I the maximum length of the array + +int npts + +begin + if (CQ_CAT(cq) == NULL) + call error (0, "The current catalog is undefined") + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + call error (0, "The current catalog is undefined") + + call cq_dgai (cq, CQ_CATNO(cq), field, array, max_len, npts) + + return (npts) +end + + +# CQ_FGAR -- Get an array valued real parameter. + +int procedure cq_fgar (cq, field, array, max_len) + +pointer cq #I the catalog descriptor +char field[ARB] #I the field name +real array[ARB] #O the output array +int max_len #I the maximum length of the array + +int npts + +begin + if (CQ_CAT(cq) == NULL) + call error (0, "The current catalog is undefined") + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + call error (0, "The current catalog is undefined") + + call cq_dgar (cq, CQ_CATNO(cq), field, array, max_len, npts) + + return (npts) +end + + +# CQ_FGAD -- Get an array valued double parameter. + +int procedure cq_fgad (cq, field, array, max_len) + +pointer cq #I the catalog descriptor +char field[ARB] #I the field name +double array[ARB] #O the output array +int max_len #I the maximum length of the array + +int npts + +begin + if (CQ_CAT(cq) == NULL) + call error (0, "The current catalog is undefined") + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + call error (0, "The current catalog is undefined") + + call cq_dgad (cq, CQ_CATNO(cq), field, array, max_len, npts) + + return (npts) +end + + +# CQ_FGWRD -- Fetch a single word field from the current catalog. + +procedure cq_fgwrd (cq, field, str, maxch) + +pointer cq #I the catalog descriptor +char field[ARB] #I the field name +char str[ARB] #O the output string +int maxch #I the maximum number of characters + +errchk cq_dgwrd() + +begin + if (CQ_CAT(cq) == NULL) + call error (0, "The current catalog is undefined") + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + call error (0, "The current catalog is undefined") + + call cq_dgwrd (cq, CQ_CATNO(cq), field, str, maxch) +end + + +# CQ_FGSTR -- Fetch a string field from the current catalog. + +procedure cq_fgstr (cq, field, str, maxch) + +pointer cq #I the catalog descriptor +char field[ARB] #I the field name +char str[ARB] #O the output string +int maxch #I the maximum number of characters + +errchk cq_dgwrd() + +begin + if (CQ_CAT(cq) == NULL) + call error (0, "The current catalog is undefined") + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + call error (0, "The current catalog is undefined") + + call cq_dgstr (cq, CQ_CATNO(cq), field, str, maxch) +end + + +# CQ_FGTEXT -- Fetch a multi-line text field from the current catalog. + +int procedure cq_fgtext (cq, field, str, maxch) + +pointer cq #I the catalog descriptor +char field[ARB] #I the field name +char str[ARB] #O the output string +int maxch #I the maximum number of characters + +int nlines +errchk cq_dgatxt() + +begin + if (CQ_CAT(cq) == NULL) + call error (0, "The current catalog is undefined") + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + call error (0, "The current catalog is undefined") + + call cq_dgatxt (cq, CQ_CATNO(cq), field, str, maxch, nlines) + + return (nlines) +end + + +# CQ_SCAN -- Scan the database at the current position. + +int procedure cq_scan (cq) + +pointer cq # The catalog database descriptor. + +int fscan() + +begin + return (fscan (CQ_FD(cq))) +end diff --git a/pkg/xtools/catquery/cqgfields.x b/pkg/xtools/catquery/cqgfields.x new file mode 100644 index 00000000..23b94221 --- /dev/null +++ b/pkg/xtools/catquery/cqgfields.x @@ -0,0 +1,483 @@ +include <ctype.h> +include "cqdef.h" +include "cq.h" + +# CQ_SETRECORD -- Set the the current record. What action this procedure takes +# depends on the input data type. In the case of text files this task +# sets the current record pointer and figures where in the record each +# column begins. For blocked text files the foffsets determine where each +# record begins. + +int procedure cq_setrecord (res, recptr) + +pointer res #I the results descriptor +int recptr #U the current record pointer + +pointer buf + +begin + # The record is outside the record data range. + if (recptr <= 0) { + CQ_RECPTR(res) = 0 + CQ_FNFIELDS(res) = 0 + call aclri (Memi[CQ_FINDICES(res)], CQ_MAX_NFIELDS + 1) + return (BOF) + } + if (recptr > CQ_RNRECS(res)) + return (EOF) + + CQ_RECPTR(res) = recptr + switch (CQ_RTYPE(res)) { + case CQ_STEXT: + buf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + call cq_find_fields (Memc[buf], Memi[CQ_FINDICES(res)], + CQ_MAX_NFIELDS, CQ_FNFIELDS(res)) + case CQ_BTEXT: + ; + default: + } + + return (recptr) +end + + +# CQ_GVALC -- Fetch a record field as a string value. + +int procedure cq_gvalc (res, recptr, field, str, maxch) + +pointer res #I the results descriptor +int recptr #I the current record pointer +char field[ARB] #I the record field name. +char str[ARB] #O the output string parameter +int maxch #I the maximum number of characters + +pointer fbuf +int fnum, fip, fsize +int cq_fnumber(), cq_setrecord() + +begin + # The record is outside the record data range. + str[1] = EOS + if (recptr <= 0 || recptr > CQ_RNRECS(res)) + return (0) + + # Find the field number. + fnum = cq_fnumber (res, field) + if (fnum <= 0) + return (0) + + # Set the current record if necessary. + if (recptr != CQ_RECPTR(res)) { + if (cq_setrecord (res, recptr) != recptr) + return (0) + } + + # Extract the requested field as a string. If the data is in binary + # internally this will require formatting a string. If the data is + # text this requires extracting the appropriate piece of text. + + switch (CQ_RTYPE(res)) { + + case CQ_STEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fnum = Memi[CQ_FOFFSETS(res)+fnum-1] + fip = Memi[CQ_FINDICES(res)+fnum-1] + fsize = min (maxch, Memi[CQ_FINDICES(res)+fnum] - + Memi[CQ_FINDICES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], str, fsize) + + case CQ_BTEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fip = Memi[CQ_FOFFSETS(res)+fnum-1] + fsize = min (maxch, Memi[CQ_FSIZES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], str, fsize) + + default: + fsize = 0 + + } + + return (fsize) +end + + +# CQ_GVALD -- Return a double precision field value + +int procedure cq_gvald (res, recptr, field, dval) + +pointer res #I the results descriptor +int recptr #I the current record pointer +char field[ARB] #I the record field name. +double dval #O the output double value + +pointer fbuf, sp, line +int fnum, fip, fsize, nchars +int cq_fnumber(), ctod(), cq_setrecord() + +begin + dval = INDEFD + + # The record is outside the record data range. + if (recptr <= 0 || recptr > CQ_RNRECS(res)) + return (0) + + # Find the field number. + fnum = cq_fnumber (res, field) + if (fnum <= 0) + return (0) + + # Set the current record if necessary. + if (recptr != CQ_RECPTR(res)) { + if (cq_setrecord (res, recptr) != recptr) + return (0) + } + + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Extract the requested field as a double precision value. If the data + # is in binary internally this may imply a type conversion. If the data + # is text this requires decoding the string value. + + switch (CQ_RTYPE(res)) { + + case CQ_STEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fnum = Memi[CQ_FOFFSETS(res)+fnum-1] + fip = Memi[CQ_FINDICES(res)+fnum-1] + fsize = min (SZ_LINE, Memi[CQ_FINDICES(res)+fnum] - + Memi[CQ_FINDICES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], Memc[line], fsize) + fip = 1 + nchars = ctod (Memc[line], fip, dval) + + case CQ_BTEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fip = Memi[CQ_FOFFSETS(res)+fnum-1] + fsize = min (SZ_LINE, Memi[CQ_FSIZES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], Memc[line], fsize) + fip = 1 + nchars = ctod (Memc[line], fip, dval) + + default: + nchars = 0 + + } + + call sfree (sp) + + return (nchars) +end + + +# CQ_GVALR -- Return a real precision field value. + +int procedure cq_gvalr (res, recptr, field, rval) + +pointer res #I the results descriptor +int recptr #I the current record pointer +char field[ARB] #I the record field name. +real rval #O the output real value + +pointer fbuf, sp, line +int fnum, fip, fsize, nchars +int cq_fnumber(), ctor(), cq_setrecord() + +begin + rval = INDEFR + + # The record is outside the record data range. + if (recptr <= 0 || recptr > CQ_RNRECS(res)) + return (0) + + # Find the field number. + fnum = cq_fnumber (res, field) + if (fnum <= 0) + return (0) + + # Set the current record if necessary. + if (recptr != CQ_RECPTR(res)) { + if (cq_setrecord (res, recptr) != recptr) + return (0) + } + + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Extract the requested field as a double precision value. If the data + # is in binary internally this may imply a type conversion. If the data + # is text this requires decoding the string value. + + switch (CQ_RTYPE(res)) { + + case CQ_STEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fnum = Memi[CQ_FOFFSETS(res)+fnum-1] + fip = Memi[CQ_FINDICES(res)+fnum-1] + fsize = min (SZ_LINE, Memi[CQ_FINDICES(res)+fnum] - + Memi[CQ_FINDICES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], Memc[line], fsize) + fip = 1 + nchars = ctor (Memc[line], fip, rval) + + case CQ_BTEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fip = Memi[CQ_FOFFSETS(res)+fnum-1] + fsize = min (SZ_LINE, Memi[CQ_FSIZES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], Memc[line], fsize) + fip = 1 + nchars = ctor (Memc[line], fip, rval) + + default: + nchars = 0 + + } + + call sfree (sp) + + return (nchars) +end + + +# CQ_GVALL -- Return a long integer field value. + +int procedure cq_gvall (res, recptr, field, lval) + +pointer res #I the results descriptor +int recptr #I the current record pointer +char field[ARB] #I the record field name. +long lval #I the output long value + +pointer fbuf, sp, line +int fnum, fip, fsize, nchars +int cq_fnumber(), ctol(), cq_setrecord() + +begin + lval = INDEFL + + # The record is outside the record data range. + if (recptr <= 0 || recptr > CQ_RNRECS(res)) + return (0) + + # Find the field number. + fnum = cq_fnumber (res, field) + if (fnum <= 0) + return (0) + + # Set the current record if necessary. + if (recptr != CQ_RECPTR(res)) { + if (cq_setrecord (res, recptr) != recptr) + return(0) + } + + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Extract the requested field as a double precision value. If the data + # is in binary internally this may imply a type conversion. If the data + # is text this requires decoding the string value. + + switch (CQ_RTYPE(res)) { + + case CQ_STEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fnum = Memi[CQ_FOFFSETS(res)+fnum-1] + fip = Memi[CQ_FINDICES(res)+fnum-1] + fsize = min (SZ_LINE, Memi[CQ_FINDICES(res)+fnum] - + Memi[CQ_FINDICES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], Memc[line], fsize) + fip = 1 + nchars = ctol (Memc[line], fip, lval) + + case CQ_BTEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fip = Memi[CQ_FOFFSETS(res)+fnum-1] + fsize = min (SZ_LINE, Memi[CQ_FSIZES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], Memc[line], fsize) + fip = 1 + nchars = ctol (Memc[line], fip, lval) + + default: + nchars = 0 + + } + + call sfree (sp) + + return (nchars) +end + + +# CQ_GVALI -- Return an integer field value + +int procedure cq_gvali (res, recptr, field, ival) + +pointer res #I the results descriptor +int recptr #I the current record pointer +char field[ARB] #I the record field name. +int ival #I the output int value + +pointer fbuf, sp, line +int fnum, fip, fsize, nchars +int cq_fnumber(), ctoi(), cq_setrecord() + +begin + ival = INDEFI + + # The record is outside the record data range. + if (recptr <= 0 || recptr > CQ_RNRECS(res)) + return (0) + + # Find the field number. + fnum = cq_fnumber (res, field) + if (fnum <= 0) + return (0) + + # Set the current record if necessary. + if (recptr != CQ_RECPTR(res)) { + if (cq_setrecord (res, recptr) != recptr) + return (0) + } + + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Extract the requested field as a double precision value. If the data + # is in binary internally this may imply a type conversion. If the data + # is text this requires decoding the string value. + + switch (CQ_RTYPE(res)) { + + case CQ_STEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fnum = Memi[CQ_FOFFSETS(res)+fnum-1] + fip = Memi[CQ_FINDICES(res)+fnum-1] + fsize = min (SZ_LINE, Memi[CQ_FINDICES(res)+fnum] - + Memi[CQ_FINDICES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], Memc[line], fsize) + fip = 1 + nchars = ctoi (Memc[line], fip, ival) + + case CQ_BTEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fip = Memi[CQ_FOFFSETS(res)+fnum-1] + fsize = min (SZ_LINE, Memi[CQ_FSIZES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], Memc[line], fsize) + fip = 1 + nchars = ctoi (Memc[line], fip, ival) + + default: + nchars = 0 + } + + call sfree (sp) + + return (nchars) +end + + +# CQ_GVALS -- Return a short integer field value + +int procedure cq_gvals (res, recptr, field, sval) + +pointer res #I the results descriptor +int recptr #I the current record pointer +char field[ARB] #I the record field name. +short sval #O the output short value + +pointer fbuf, sp, line +int fnum, fip, fsize, nchars, ival +int cq_fnumber(), ctoi(), cq_setrecord() + +begin + sval = INDEFS + + # The record is outside the record data range. + if (recptr <= 0 || recptr > CQ_RNRECS(res)) + return (0) + + # Find the field number. + fnum = cq_fnumber (res, field) + if (fnum <= 0) + return (0) + + # Set the current record if necessary. + if (recptr != CQ_RECPTR(res)) { + if (cq_setrecord (res, recptr) != recptr) + return (0) + } + + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Extract the requested field as a double precision value. If the data + # is in binary internally this may imply a type conversion. If the data + # is text this requires decoding the string value. + + switch (CQ_RTYPE(res)) { + + case CQ_STEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fnum = Memi[CQ_FOFFSETS(res)+fnum-1] + fip = Memi[CQ_FINDICES(res)+fnum-1] + fsize = min (SZ_LINE, Memi[CQ_FINDICES(res)+fnum] - + Memi[CQ_FINDICES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], Memc[line], fsize) + fip = 1 + nchars = ctoi (Memc[line], fip, ival) + if (nchars > 0) + sval = ival + + case CQ_BTEXT: + fbuf = CQ_RBUF(res) + Memi[CQ_RINDEX(res)+recptr-1] - 1 + fip = Memi[CQ_FOFFSETS(res)+fnum-1] + fsize = min (SZ_LINE, Memi[CQ_FSIZES(res)+fnum-1]) + call strcpy (Memc[fbuf+fip-1], Memc[line], fsize) + fip = 1 + nchars = ctoi (Memc[line], fip, ival) + if (nchars > 0) + sval = ival + + default: + nchars = 0 + + } + + call sfree (sp) + + return (nchars) +end + + +# CQ_FIND_FIELDS -- This procedure finds the starting column for each field +# in the input line. These column numbers are returned in the array +# field_pos; the number of fields is also returned. + +procedure cq_find_fields (linebuf, field_pos, max_fields, nfields) + +char linebuf[ARB] #I the input buffer +int field_pos[max_fields] #O the output field positions +int max_fields #I the maximum number of fields +int nfields #O the computed number of fields + +bool in_field +int ip, field_num + +begin + field_num = 1 + field_pos[1] = 1 + in_field = false + + for (ip=1; linebuf[ip] != '\n' && linebuf[ip] != EOS; ip=ip+1) { + if (! IS_WHITE(linebuf[ip])) + in_field = true + else if (in_field) { + in_field = false + field_num = field_num + 1 + field_pos[field_num] = ip + } + } + + field_pos[field_num+1] = ip + nfields = field_num +end diff --git a/pkg/xtools/catquery/cqgqpars.x b/pkg/xtools/catquery/cqgqpars.x new file mode 100644 index 00000000..627dd053 --- /dev/null +++ b/pkg/xtools/catquery/cqgqpars.x @@ -0,0 +1,99 @@ +include "cqdef.h" + + +# CQ_GQPAR -- Get the default value, units, and format for a query parameter +# by name. + +int procedure cq_gqpar (cq, name, pname, max_name, value, max_val, units, + max_units, format, max_format) + +pointer cq #I the catalog descriptor +char name[ARB] #I the input query parameter name +char pname[ARB] #I the output query parameter name +int max_name #I the max size of the parameter name +char value[ARB] #O the default value size +int max_val #I the max size of the parameter value +char units[ARB] #O the units string +int max_units #I the max size of the parameter units +char format[ARB] #O the format string +int max_format #I the max size of the parameter format + +pointer cc +int parno +int strdic(), cq_wrdstr() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (0) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (0) + cc = CQ_CAT(cq) + + parno = strdic (name, pname, max_name, Memc[CQ_PQPNAMES(cc)]) + if (parno <= 0) + return (0) + + parno = cq_wrdstr (parno, value, max_val, Memc[CQ_PQPDVALUES(cc)]) + if (parno <= 0) + return (0) + + parno = cq_wrdstr (parno, units, max_units, Memc[CQ_PQPUNITS(cc)]) + if (parno <= 0) + return (0) + + parno = cq_wrdstr (parno, format, max_format, Memc[CQ_PQPFMTS(cc)]) + if (parno <= 0) + return (0) + + return (parno) +end + + +# CQ_GQPARN -- Get the default value, units, and format for a query parameter +# by number. + +int procedure cq_gqparn (cq, parno, pname, max_name, value, max_val, units, + max_units, format, max_format) + +pointer cq #I the catalog descriptor +int parno #I the parameter number +char pname[ARB] #I the output query parameter name +int max_name #I the max size of the parameter name +char value[ARB] #O the default value size +int max_val #I the max size of the parameter value +char units[ARB] #O the units string +int max_units #I the max size of the parameter units +char format[ARB] #O the format string +int max_format #I the max size of the parameter format + +pointer cc +int pnum +int cq_wrdstr() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (0) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (0) + cc = CQ_CAT(cq) + + pnum = cq_wrdstr (parno, pname, max_name, Memc[CQ_PQPNAMES(cc)]) + if (pnum <= 0) + return (0) + + pnum = cq_wrdstr (parno, value, max_val, Memc[CQ_PQPDVALUES(cc)]) + if (pnum <= 0) + return (0) + + pnum = cq_wrdstr (parno, units, max_units, Memc[CQ_PQPUNITS(cc)]) + if (pnum <= 0) + return (0) + + pnum = cq_wrdstr (parno, format, max_format, Memc[CQ_PQPFMTS(cc)]) + if (pnum <= 0) + return (0) + + return (pnum) +end diff --git a/pkg/xtools/catquery/cqgrecords.x b/pkg/xtools/catquery/cqgrecords.x new file mode 100644 index 00000000..f7debe94 --- /dev/null +++ b/pkg/xtools/catquery/cqgrecords.x @@ -0,0 +1,83 @@ +include "cqdef.h" +include "cq.h" + + +# CQ_GNRECORD -- Get next record from the results descriptor. + +int procedure cq_gnrecord (res, buf, maxch, recptr) + +pointer res #I the results descriptor +char buf[ARB] #O the output record buffer +int maxch #I the maximum buffer size +int recptr #U the current record pointer + +int nchars +int getline() + +begin + # The record is outside the record data range. + if (recptr < 0) + return (BOF) + if (recptr >= CQ_RNRECS(res)) + return (EOF) + + # Use file mechanism to extract record. Could also use buffer pointer + # and offsets + + switch (CQ_RTYPE(res)) { + + # Don't worry about maxch at the moment. Just assume that the + # buffer is at least SZ_LINE long. Can use recsize to return + # a buffer, SZ_LINE is the default. May need to use getlline + # in future. + + case CQ_STEXT, CQ_BTEXT: + call seek (CQ_RFD(res), Meml[CQ_RINDEX(res)+recptr]) + nchars = getline (CQ_RFD(res), buf) + recptr = recptr + 1 + return (nchars) + + default: + return (EOF) + } +end + + +# CQ_GRECORD -- Get a specified record from the results descriptor. + +int procedure cq_grecord (res, buf, maxch, recptr) + +pointer res #I the results descriptor +char buf[ARB] #O the output record buffer +int maxch #I the maximum buffer size +int recptr #I the record to be extracted + +int nchars +int getline() + +begin + # Check for out-of-bounds record requests. + if (recptr < 1) + return (BOF) + if (recptr > CQ_RNRECS(res)) + return (EOF) + + # Use file mechanism to extract record. Could also use buffer pointer + # and offsets + + switch (CQ_RTYPE(res)) { + + # Don't worry about maxch at the moment. Just assume that the + # buffer is at least SZ_LINE long. Can use recsize to return + # a buffer, SZ_LINE is the default. May need to use getlline + # in future. + + case CQ_STEXT, CQ_BTEXT: + call seek (CQ_RFD(res), Meml[CQ_RINDEX(res)+recptr-1]) + nchars = getline (CQ_RFD(res), buf) + return (nchars) + + default: + return (EOF) + } +end diff --git a/pkg/xtools/catquery/cqiminfo.x b/pkg/xtools/catquery/cqiminfo.x new file mode 100644 index 00000000..898d1ed2 --- /dev/null +++ b/pkg/xtools/catquery/cqiminfo.x @@ -0,0 +1,220 @@ +include "cqdef.h" +include "cq.h" + + +# CQ_WINFO -- Get the WCS field description by field name. + +int procedure cq_winfo (res, wfield, wkname, sz_wkname, wkvalue, sz_wkvalue, + wktype, wkunits, sz_wkunits) + +pointer res #I the results descriptor +char wfield[ARB] #I the field name +char wkname[ARB] #O the output keyword name +int sz_wkname #I the maximum size of the keyword name string +char wkvalue[ARB] #O the current value string +int sz_wkvalue #I the maximum size of the current value string +int wktype #O the output field datatype +char wkunits[ARB] #O the outpit field units string +int sz_wkunits #I the maximum size of the units string + +pointer sp, fname +int fieldno +int strdic(), cq_wrdstr() + +begin + # Return if there are no fields. + if (CQ_NWCS(res) <= 0) + return (0) + + call smark (sp) + call salloc (fname, CQ_SZ_FNAME, TY_CHAR) + + # Find the requested field. + fieldno = strdic (wfield, Memc[fname], CQ_SZ_FNAME, + Memc[CQ_WPNAMES(res)]) + if (fieldno <= 0) { + call sfree (sp) + return (0) + } + + # Get the field keyword name. + if (cq_wrdstr (fieldno, wkname, sz_wkname, Memc[CQ_WKNAMES(res)]) <= 0) + wkname[1] = EOS + + # Get the field keyword value. + if (cq_wrdstr (fieldno, wkvalue, sz_wkvalue, + Memc[CQ_WKVALUES(res)]) <= 0) + wkvalue[1] = EOS + + # Get the field type. + wktype = Memi[CQ_WKTYPES(res)+fieldno-1] + + # Get the field units. + if (cq_wrdstr (fieldno, wkunits, sz_wkunits, + Memc[CQ_WKUNITS(res)]) <= 0) + wkunits[1] = EOS + + call sfree (sp) + + return (fieldno) +end + + +# CQ_WINFON -- Get the WCS field description by field number. + +int procedure cq_winfon (res, fieldno, wfield, sz_wfield, wkname, sz_wkname, + wkvalue, sz_wkvalue, wktype, wkunits, sz_wkunits) + +pointer res #I the results descriptor +int fieldno #I the input field number +char wfield[ARB] #O the field name +int sz_wfield #I the maximum size of the field string +char wkname[ARB] #O the output keyword name +int sz_wkname #I the maximum size of the keyword name string +char wkvalue[ARB] #O the current value string +int sz_wkvalue #I the maximum size of the current value string +int wktype #O the output field datatype +char wkunits[ARB] #O the outpit field units string +int sz_wkunits #I the maximum size of the units string + +int cq_wrdstr() + +begin + # Return if there are no fields. + if (CQ_NWCS(res) <= 0) + return (0) + if (fieldno <= 0 || fieldno > CQ_NWCS(res)) + return (0) + + # Get the field name. + if (cq_wrdstr (fieldno, wfield, sz_wfield, Memc[CQ_WPNAMES(res)]) <= 0) + return (0) + + # Get the field keyword name. + if (cq_wrdstr (fieldno, wkname, sz_wkname, Memc[CQ_WKNAMES(res)]) <= 0) + wkname[1] = EOS + + # Get the field keyword value. + if (cq_wrdstr (fieldno, wkvalue, sz_wkvalue, + Memc[CQ_WKVALUES(res)]) <= 0) + wkvalue[1] = EOS + + # Get the field type. + wktype = Memi[CQ_WKTYPES(res)+fieldno-1] + + # Get the field units. + if (cq_wrdstr (fieldno, wkunits, sz_wkunits, + Memc[CQ_WKUNITS(res)]) <= 0) + wkunits[1] = EOS + + return (fieldno) +end + + +# CQ_KINFO -- Get the keyword field description by field name. + +int procedure cq_kinfo (res, kfield, ikname, sz_ikname, ikvalue, sz_ikvalue, + iktype, ikunits, sz_ikunits) + +pointer res #I the results descriptor +char kfield[ARB] #I the field name +char ikname[ARB] #O the output keyword name +int sz_ikname #I the maximum size of the keyword name string +char ikvalue[ARB] #O the current value string +int sz_ikvalue #I the maximum size of the current value string +int iktype #O the output field datatype +char ikunits[ARB] #O the outpit field units string +int sz_ikunits #I the maximum size of the units string + +pointer sp, fname +int fieldno +int strdic(), cq_wrdstr() + +begin + # Return if there are no fields. + if (CQ_NIMPARS(res) <= 0) + return (0) + + call smark (sp) + call salloc (fname, CQ_SZ_FNAME, TY_CHAR) + + # Find the requested field. + fieldno = strdic (kfield, Memc[fname], CQ_SZ_FNAME, + Memc[CQ_IPNAMES(res)]) + if (fieldno <= 0) { + call sfree (sp) + return (0) + } + + # Get the field keyword name. + if (cq_wrdstr (fieldno, ikname, sz_ikname, Memc[CQ_IKNAMES(res)]) <= 0) + ikname[1] = EOS + + # Get the field keyword value. + if (cq_wrdstr (fieldno, ikvalue, sz_ikvalue, + Memc[CQ_IKVALUES(res)]) <= 0) + ikvalue[1] = EOS + + # Get the field type. + iktype = Memi[CQ_IKTYPES(res)+fieldno-1] + + # Get the field units. + if (cq_wrdstr (fieldno, ikunits, sz_ikunits, + Memc[CQ_IKUNITS(res)]) <= 0) + ikunits[1] = EOS + + call sfree (sp) + + return (fieldno) +end + + +# CQ_KINFON -- Get the image keyword field description by field number. + +int procedure cq_kinfon (res, fieldno, kfield, sz_kfield, ikname, sz_ikname, + ikvalue, sz_ikvalue, iktype, ikunits, sz_ikunits) + +pointer res #I the results descriptor +int fieldno #I the input field number +char kfield[ARB] #O the field name +int sz_kfield #I the maximum size of the field string +char ikname[ARB] #O the output keyword name +int sz_ikname #I the maximum size of the keyword name string +char ikvalue[ARB] #O the current value string +int sz_ikvalue #I the maximum size of the current value string +int iktype #O the output field datatype +char ikunits[ARB] #O the outpit field units string +int sz_ikunits #I the maximum size of the units string + +int cq_wrdstr() + +begin + # Return if there are no fields. + if (CQ_NIMPARS(res) <= 0) + return (0) + if (fieldno <= 0 || fieldno > CQ_NIMPARS(res)) + return (0) + + # Get the field name. + if (cq_wrdstr (fieldno, kfield, sz_kfield, Memc[CQ_IPNAMES(res)]) <= 0) + return (0) + + # Get the field keyword name. + if (cq_wrdstr (fieldno, ikname, sz_ikname, Memc[CQ_IKNAMES(res)]) <= 0) + ikname[1] = EOS + + # Get the field keyword value. + if (cq_wrdstr (fieldno, ikvalue, sz_ikvalue, Memc[CQ_IKVALUES(res)]) <= + 0) + ikvalue[1] = EOS + + # Get the field type. + iktype = Memi[CQ_IKTYPES(res)+fieldno-1] + + # Get the field units. + if (cq_wrdstr (fieldno, ikunits, sz_ikunits, Memc[CQ_IKUNITS(res)]) <= + 0) + ikunits[1] = EOS + + return (fieldno) +end diff --git a/pkg/xtools/catquery/cqimquery.x b/pkg/xtools/catquery/cqimquery.x new file mode 100644 index 00000000..28a2957c --- /dev/null +++ b/pkg/xtools/catquery/cqimquery.x @@ -0,0 +1,931 @@ +include <fset.h> +include <ctype.h> +include "cqdef.h" +include "cq.h" + + +define DEF_SZ_INBUF 32768 # the maximum network transfer buffer size + + +# CQ_FIMQUERY -- Send a dummy image query on an existing image. The immage +# may be any supported IRAF images. + +pointer procedure cq_fimquery (cq, imname) + +pointer cq #I the catalog database descriptor +char imname[ARB] #I the input image name + +pointer res +int cc +pointer cq_firinit() +int imaccess() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (NULL) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (NULL) + cc = CQ_CAT(cq) + + # Open the network connection. + if (imaccess (imname, READ_WRITE) != YES) + return (NULL) + + # Initialize the image results structure. + res = cq_firinit (cq) + + # Return the results pointer. + return (res) +end + + +# CQ_IMQUERY -- Send an image survey query and return the image as a file. +# Currently only FITS files are supported. The calling program is responsible +# for generating an IRAF compatible image name. If the file already exists +# no file is created but a valid results descriptor is still created. + +pointer procedure cq_imquery (cq, imname) + +pointer cq #I the catalog database descriptor +char imname[ARB] #I the image name + +pointer res, inbuf +char url[SZ_PATHNAME], addr[SZ_LINE], query[SZ_LINE], buf[SZ_LINE] +int cc, fd, outfd, nchars, ip, op +bool done +pointer cq_irinit() +int ndopen(), strlen(), open(), read(), getline(), url_get() +errchk ndopen(), awriteb(), open(), read(), getline() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (NULL) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (NULL) + cc = CQ_CAT(cq) + + + if (USE_URLGET) { + # Initialize the image results structure. + res = cq_irinit (cq) + + call strcpy (CQ_ADDRESS(cc), buf, SZ_LINE) + for (ip=1; buf[ip] != ':'; ip=ip+1) ; # skip 'inet:' + ip = ip + 1 + for ( ; buf[ip] != ':'; ip=ip+1) ; # skip '80:' + ip = ip + 1 + for (op=1; buf[ip] != ':'; ip=ip+1) { + addr[op] = buf[ip] + op = op + 1 + } + addr[op] = EOS + + call strcpy (CQ_IMQUERY(res), buf, SZ_LINE) + for (op=1; !IS_WHITE(buf[op+4]); op=op+1) + query[op] = buf[op+4] + query[op] = EOS + + call sprintf (url, SZ_LINE, "http://%s%s") + call pargstr (addr) + call pargstr (query) + + iferr { + call malloc (inbuf, DEF_SZ_INBUF, TY_CHAR) + if (url_get (url, imname, inbuf) < 0) + call error (0, "Cannot access url") + call mfree (inbuf, TY_CHAR) + } then { + if (res != NULL) + call cq_imclose (res) + return (NULL) + } + + return (res) + } + + + # Open the network connection. + iferr (fd = ndopen (CQ_ADDRESS(cc), READ_WRITE)) + return (NULL) + + # Initialize the image results structure. + res = cq_irinit (cq) + + # Formulate the query. + iferr { + switch (CQ_IMTYPE(res)) { + case CQ_FITS: + nchars = strlen (CQ_IMQUERY(res)) + call write (fd, CQ_IMQUERY(res), nchars) + default: + nchars = strlen (CQ_IMQUERY(res)) + call write (fd, CQ_IMQUERY(res), nchars) + } + call flush (fd) + call fseti (fd, F_CANCEL, OK) + } then { + if (fd != NULL) + call close (fd) + if (res != NULL) + call cq_imclose (res) + return (NULL) + } + + # Open the output file. + outfd = NULL + iferr { + # Open the output file. Worry about legal image names at a + # higher level. + switch (CQ_IMTYPE(res)) { + case CQ_FITS: + outfd = open (imname, NEW_FILE, TEXT_FILE) + default: + outfd = open (imname, NEW_FILE, TEXT_FILE) + } + } then { + if (fd != NULL) + call close (fd) + if (res != NULL) + call cq_imclose (res) + return (NULL) + } + + # Send the query and get back the results. + inbuf = NULL + iferr { + + # Allocate the maximum buffer size. + call malloc (inbuf, DEF_SZ_INBUF, TY_CHAR) + + # Skip a fixed number of bytes. Dangerous unless the header + # is always the same size. + switch (CQ_HFMT(cc)) { + case CQ_HNONE: + ; + case CQ_HHTTP: + repeat { + nchars = getline (fd, Memc[inbuf]) + if (nchars <= 0) + break + Memc[inbuf+nchars] = EOS + } until ((Memc[inbuf] == '\r' && Memc[inbuf+1] == '\n') || + (Memc[inbuf] == '\n')) + default: + ; + } + + # Get the data. + repeat { + nchars = read (fd, Memc[inbuf], DEF_SZ_INBUF) + if (nchars > 0) { + Memc[inbuf+nchars] = EOS + call write (outfd, Memc[inbuf], nchars) + done = false + } else { + done = true + } + } until (done) + + # Cleanup. + call mfree (inbuf, TY_CHAR) + inbuf = NULL + call flush (outfd) + call close (outfd) + outfd = NULL + call close (fd) + fd = NULL + + } then { + if (inbuf != NULL) + call mfree (inbuf, TY_CHAR) + if (outfd != NULL) { + call close (outfd) + call delete (imname) + } + if (fd != NULL) + call close (fd) + if (res != NULL) + call cq_imclose (res) + return (NULL) + } + + # Return the results pointer. + return (res) +end + + +# CQ_IMCLOSE -- Close the results structure, + +procedure cq_imclose (res) + +pointer res #U the results descriptor. + +begin + call cq_irfree (res) +end + + +# CQ_FIRINIT -- Initialize an image results descriptor. + +pointer procedure cq_firinit (cq) + +pointer cq #I the catalog descriptor + +pointer cc, res +pointer sp, value, wpname, wkname, wkdvalue, wkvalue, wkunits +int i, ncount, sz1, sz2, sz3, sz4, sz5, op1, op2, op3, op4, op5 +char ftype +int cq_dgeti(), strdic(), cq_dscan(), nscan() +int gstrcpy(), cq_dtype() +errchk cq_dgwrd(), cq_dgeti(), cq_dscan() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (NULL) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (NULL) + cc = CQ_CAT(cq) + + # Allocate the results structure. + call calloc (res, CQ_LEN_IM, TY_STRUCT) + + # Format the query. + call smark (sp) + call salloc (value, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (wpname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (wkname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (wkdvalue, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (wkvalue, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (wkunits, CQ_SZ_QPUNITS, TY_CHAR) + + # Save the survey informaton and query in the results structure. + call strcpy (CQ_CATDB(cq), CQ_IMCATDB(res), SZ_FNAME) + call strcpy (CQ_CATNAME(cq), CQ_IMCATNAME(res), SZ_FNAME) + call strcpy ("", CQ_IMADDRESS(res), SZ_LINE) + call strcpy ("", CQ_IMQUERY(res), SZ_LINE) + + # Copy the query parameters to the results descriptor. + CQ_INQPARS(res) = 0 + CQ_IQPNAMES(res) = NULL + CQ_IQPVALUES(res) = NULL + CQ_IQPUNITS(res) = NULL + + # Get the input image data type. + iferr { + call cq_dgwrd (cq, CQ_CATNO(cq), "type", Memc[value], + CQ_SZ_QPVALUE) + } then { + Memc[value] = EOS + CQ_IMTYPE(res) = CQ_FITS + } else { + CQ_IMTYPE(res) = strdic (Memc[value], Memc[value], CQ_SZ_QPVALUE, + CQ_ITYPESTR) + } + + # Get the input image data type. + iferr { + call cq_dgwrd (cq, CQ_CATNO(cq), "wcs", Memc[value], + CQ_SZ_QPVALUE) + } then { + CQ_IMTYPE(res) = CQ_WNONE + } else { + CQ_WCS(res) = strdic (Memc[value], Memc[value], CQ_SZ_QPVALUE, + CQ_WTYPESTR) + } + + # Get the number of wcs parameters. + iferr (CQ_NWCS(res) = cq_dgeti (cq, CQ_CATNO(cq), "nwcs")) + CQ_NWCS(res) = 0 + + # Allocate space for the wcs parameters. + call calloc (CQ_WPNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_WKNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_WKDVALUES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_WKVALUES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_WKTYPES(res), CQ_NWCS(res), TY_INT) + call calloc (CQ_WKUNITS(res), SZ_LINE, TY_CHAR) + + # Get the wcs parameters. + ncount = 0 + if (CQ_NWCS(res) > 0) { + + # Initialize the header parameter keywords and values. + sz1 = SZ_LINE; op1 = 2 + sz2 = SZ_LINE; op2 = 2 + sz3 = SZ_LINE; op3 = 2 + sz4 = SZ_LINE; op4 = 2 + sz5 = SZ_LINE; op5 = 2 + call strcpy ("|", Memc[CQ_WPNAMES(res)], sz1) + call strcpy ("|", Memc[CQ_WKNAMES(res)], sz2) + call strcpy ("|", Memc[CQ_WKDVALUES(res)], sz3) + call strcpy ("|", Memc[CQ_WKVALUES(res)], sz4) + call strcpy ("|", Memc[CQ_WKUNITS(res)], sz5) + + do i = 1, CQ_NWCS(res) { + + # Get the wcs parameter name, keyword, default value, + # data type and units value. + if (cq_dscan (cq) == EOF) + break + call gargwrd (Memc[wpname], CQ_SZ_QPNAME) + call gargwrd (Memc[wkname], CQ_SZ_QPNAME) + call gargwrd (Memc[wkdvalue], CQ_SZ_QPVALUE) + call gargc (ftype) + call gargwrd (Memc[wkunits], CQ_SZ_QPUNITS) + if (nscan() != 5) + break + + # Add the parameter name to the list. + if ((sz1 - op1 + 1) < (CQ_SZ_QPNAME + 1)) { + sz1 = sz1 + SZ_LINE + call realloc (CQ_WPNAMES(res), sz1, TY_CHAR) + } + op1 = op1 + gstrcpy (Memc[wpname], Memc[CQ_WPNAMES(res)+op1-1], + sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[CQ_WPNAMES(res)+op1-1], + sz1 - op1 + 1) + + # Add the keyword name to the list. + if ((sz2 - op2 + 1) < (CQ_SZ_QPNAME + 1)) { + sz2 = sz2 + SZ_LINE + call realloc (CQ_WKNAMES(res), sz2, TY_CHAR) + } + op2 = op2 + gstrcpy (Memc[wkname], Memc[CQ_WKNAMES(res)+op2-1], + sz2 - op2 + 1) + op2 = op2 + gstrcpy ("|", Memc[CQ_WKNAMES(res)+op2-1], + sz2 - op2 + 1) + + # Add the default keyword value to the list. + if ((sz3 - op3 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz3 = sz3 + SZ_LINE + call realloc (CQ_WKDVALUES(res), sz3, TY_CHAR) + } + op3 = op3 + gstrcpy (Memc[wkdvalue], + Memc[CQ_WKDVALUES(res)+op3-1], sz3 - op3 + 1) + op3 = op3 + gstrcpy ("|", Memc[CQ_WKDVALUES(res)+op3-1], + sz3 - op3 + 1) + + # Add the keyword value to the list. + if ((sz4 - op4 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz4 = sz4 + SZ_LINE + call realloc (CQ_WKVALUES(res), sz4, TY_CHAR) + } + op4 = op4 + gstrcpy (Memc[wkdvalue], + Memc[CQ_WKVALUES(res)+op4-1], sz4 - op4 + 1) + op4 = op4 + gstrcpy ("|", Memc[CQ_WKVALUES(res)+op4-1], + sz4 - op4 + 1) + + # Compute the data type. + Memi[CQ_WKTYPES(res)+i-1] = cq_dtype (ftype) + + # Add the default keyword value to the list. + if ((sz5 - op5 + 1) < (CQ_SZ_QPUNITS + 1)) { + sz5 = sz5 + SZ_LINE + call realloc (CQ_WKUNITS(res), sz5, TY_CHAR) + } + op5 = op5 + gstrcpy (Memc[wkunits], + Memc[CQ_WKUNITS(res)+op5-1], sz5 - op5 + 1) + op5 = op5 + gstrcpy ("|", Memc[CQ_WKUNITS(res)+op5-1], + sz5 - op5 + 1) + + ncount = ncount + 1 + } + } + + # Resize the wcs parameter arrays. + if (ncount != CQ_NWCS(res)) { + CQ_NWCS(res) = 0 + call realloc (CQ_WPNAMES(res), 1, TY_CHAR) + call realloc (CQ_WKNAMES(res), 1, TY_CHAR) + call realloc (CQ_WKDVALUES(res), 1, TY_CHAR) + call realloc (CQ_WKVALUES(res), 1, TY_CHAR) + call mfree (CQ_WKTYPES(res), TY_INT) + CQ_WKTYPES(res) = NULL + call realloc (CQ_WKUNITS(res), 1, TY_CHAR) + } else { + call realloc (CQ_WPNAMES(res), op1, TY_CHAR) + call realloc (CQ_WKNAMES(res), op2, TY_CHAR) + call realloc (CQ_WKDVALUES(res), op3, TY_CHAR) + call realloc (CQ_WKVALUES(res), op4, TY_CHAR) + call realloc (CQ_WKUNITS(res), op5, TY_CHAR) + Memc[CQ_WPNAMES(res)+op1] = EOS + Memc[CQ_WKNAMES(res)+op2] = EOS + Memc[CQ_WKDVALUES(res)+op3] = EOS + Memc[CQ_WKVALUES(res)+op4] = EOS + Memc[CQ_WKUNITS(res)+op5] = EOS + } + + # Get the number of keyword parameters. + iferr (CQ_NIMPARS(res) = cq_dgeti (cq, CQ_CATNO(cq), "nkeys")) + CQ_NIMPARS(res) = 0 + + # Allocate space for the keyword parameters. + call calloc (CQ_IPNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_IKNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_IKDVALUES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_IKVALUES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_IKTYPES(res), CQ_NIMPARS(res), TY_INT) + call calloc (CQ_IKUNITS(res), SZ_LINE, TY_CHAR) + + # Get the keyword parameters. + ncount = 0 + if (CQ_NIMPARS(res) > 0) { + + # Initialize the header parameter keywords and values. + sz1 = SZ_LINE; op1 = 2 + sz2 = SZ_LINE; op2 = 2 + sz3 = SZ_LINE; op3 = 2 + sz4 = SZ_LINE; op4 = 2 + sz5 = SZ_LINE; op5 = 2 + call strcpy ("|", Memc[CQ_IPNAMES(res)], sz1) + call strcpy ("|", Memc[CQ_IKNAMES(res)], sz2) + call strcpy ("|", Memc[CQ_IKDVALUES(res)], sz3) + call strcpy ("|", Memc[CQ_IKVALUES(res)], sz4) + call strcpy ("|", Memc[CQ_IKUNITS(res)], sz5) + + do i = 1, CQ_NIMPARS(res) { + + # Get the wcs parameter name, keyword, default value, + # data type and units value. + if (cq_dscan (cq) == EOF) + break + call gargwrd (Memc[wpname], CQ_SZ_QPNAME) + call gargwrd (Memc[wkname], CQ_SZ_QPNAME) + call gargwrd (Memc[wkdvalue], CQ_SZ_QPVALUE) + call gargc (ftype) + call gargwrd (Memc[wkunits], CQ_SZ_QPUNITS) + if (nscan() != 5) + break + + # Add the parameter name to the list. + if ((sz1 - op1 + 1) < (CQ_SZ_QPNAME + 1)) { + sz1 = sz1 + SZ_LINE + call realloc (CQ_IPNAMES(res), sz1, TY_CHAR) + } + op1 = op1 + gstrcpy (Memc[wpname], Memc[CQ_IPNAMES(res)+op1-1], + sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[CQ_IPNAMES(res)+op1-1], + sz1 - op1 + 1) + + # Add the keyword name to the list. + if ((sz2 - op2 + 1) < (CQ_SZ_QPNAME + 1)) { + sz2 = sz2 + SZ_LINE + call realloc (CQ_IKNAMES(res), sz2, TY_CHAR) + } + op2 = op2 + gstrcpy (Memc[wkname], Memc[CQ_IKNAMES(res)+op2-1], + sz2 - op2 + 1) + op2 = op2 + gstrcpy ("|", Memc[CQ_IKNAMES(res)+op2-1], + sz2 - op2 + 1) + + # Add the default keyword value to the list. + if ((sz3 - op3 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz3 = sz3 + SZ_LINE + call realloc (CQ_IKDVALUES(res), sz3, TY_CHAR) + } + op3 = op3 + gstrcpy (Memc[wkdvalue], + Memc[CQ_IKDVALUES(res)+op3-1], sz3 - op3 + 1) + op3 = op3 + gstrcpy ("|", Memc[CQ_IKDVALUES(res)+op3-1], + sz3 - op3 + 1) + + # Add the keyword value to the list. + if ((sz4 - op4 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz4 = sz4 + SZ_LINE + call realloc (CQ_IKVALUES(res), sz4, TY_CHAR) + } + op4 = op4 + gstrcpy (Memc[wkdvalue], + Memc[CQ_IKVALUES(res)+op4-1], sz4 - op4 + 1) + op4 = op4 + gstrcpy ("|", Memc[CQ_IKVALUES(res)+op4-1], + sz4 - op4 + 1) + + # Compute the data type. + Memi[CQ_IKTYPES(res)+i-1] = cq_dtype (ftype) + + # Add the default keyword value to the list. + if ((sz5 - op5 + 1) < (CQ_SZ_QPUNITS + 1)) { + sz5 = sz5 + SZ_LINE + call realloc (CQ_IKUNITS(res), sz5, TY_CHAR) + } + op5 = op5 + gstrcpy (Memc[wkunits], + Memc[CQ_IKUNITS(res)+op5-1], sz5 - op5 + 1) + op5 = op5 + gstrcpy ("|", Memc[CQ_IKUNITS(res)+op5-1], + sz5 - op5 + 1) + + ncount = ncount + 1 + + } + } + + # Resize the wcs parameter arrays. + if (ncount != CQ_NIMPARS(res)) { + CQ_NIMPARS(res) = 0 + call realloc (CQ_IPNAMES(res), 1, TY_CHAR) + call realloc (CQ_IKNAMES(res), 1, TY_CHAR) + call realloc (CQ_IKDVALUES(res), 1, TY_CHAR) + call realloc (CQ_IKVALUES(res), 1, TY_CHAR) + call mfree (CQ_IKTYPES(res), TY_INT) + CQ_IKTYPES(res) = NULL + call realloc (CQ_IKUNITS(res), 1, TY_CHAR) + } else { + call realloc (CQ_IPNAMES(res), op1, TY_CHAR) + call realloc (CQ_IKNAMES(res), op2, TY_CHAR) + call realloc (CQ_IKDVALUES(res), op3, TY_CHAR) + call realloc (CQ_IKVALUES(res), op4, TY_CHAR) + call realloc (CQ_IKUNITS(res), op5, TY_CHAR) + Memc[CQ_IPNAMES(res)+op1] = EOS + Memc[CQ_IKNAMES(res)+op2] = EOS + Memc[CQ_IKDVALUES(res)+op3] = EOS + Memc[CQ_IKVALUES(res)+op4] = EOS + Memc[CQ_IKUNITS(res)+op5] = EOS + } + + call sfree (sp) + + return (res) +end + + +# CQ_IRINIT -- Initialize an image results descriptor. + +pointer procedure cq_irinit (cq) + +pointer cq #I the catalog descriptor + +pointer cc, res +pointer sp, query, value, wpname, wkname, wkdvalue, wkvalue, wkunits +int i, fsize, ncount, sz1, sz2, sz3, sz4, sz5, op1, op2, op3, op4, op5 +char ftype +int cq_wrdstr(), cq_dgeti(), strlen(), strdic(), cq_dscan(), nscan() +int gstrcpy(), cq_dtype() +errchk cq_dgwrd(), cq_dgeti(), cq_dscan() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (NULL) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (NULL) + cc = CQ_CAT(cq) + + # Allocate the results structure. + call calloc (res, CQ_LEN_IM, TY_STRUCT) + + # Format the query. + call smark (sp) + call salloc (query, SZ_LINE, TY_CHAR) + call salloc (value, CQ_SZ_QPVALUE, TY_CHAR) + call sprintf (Memc[query], SZ_LINE, CQ_QUERY(cc)) + do i = 1, CQ_NQPARS(cc) { + if (cq_wrdstr (i, Memc[value], CQ_SZ_QPVALUE, + Memc[CQ_PQPVALUES(cc)]) <= 0) + next + call pargstr (Memc[value]) + } + + # Save the survey informaton and query in the results structure. + call strcpy (CQ_CATDB(cq), CQ_IMCATDB(res), SZ_FNAME) + call strcpy (CQ_CATNAME(cq), CQ_IMCATNAME(res), SZ_FNAME) + call strcpy (CQ_ADDRESS(cc), CQ_IMADDRESS(res), SZ_LINE) + call strcpy (Memc[query], CQ_IMQUERY(res), SZ_LINE) + + # Copy the query parameters to the results descriptor. + CQ_INQPARS(res) = CQ_NQPARS(cc) + fsize = strlen (Memc[CQ_PQPNAMES(cc)]) + call malloc (CQ_IQPNAMES(res), fsize, TY_CHAR) + call strcpy (Memc[CQ_PQPNAMES(cc)], Memc[CQ_IQPNAMES(res)], fsize) + fsize = strlen (Memc[CQ_PQPVALUES(cc)]) + call malloc (CQ_IQPVALUES(res), fsize, TY_CHAR) + call strcpy (Memc[CQ_PQPVALUES(cc)], Memc[CQ_IQPVALUES(res)], fsize) + fsize = strlen (Memc[CQ_PQPUNITS(cc)]) + call malloc (CQ_IQPUNITS(res), fsize, TY_CHAR) + call strcpy (Memc[CQ_PQPUNITS(cc)], Memc[CQ_IQPUNITS(res)], fsize) + + # Get the input image data type. + iferr { + call cq_dgwrd (cq, CQ_CATNO(cq), "type", Memc[value], + CQ_SZ_QPVALUE) + } then { + Memc[value] = EOS + CQ_IMTYPE(res) = CQ_FITS + } else { + CQ_IMTYPE(res) = strdic (Memc[value], Memc[value], CQ_SZ_QPVALUE, + CQ_ITYPESTR) + } + + call salloc (wpname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (wkname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (wkdvalue, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (wkvalue, CQ_SZ_QPVALUE, TY_CHAR) + call salloc (wkunits, CQ_SZ_QPUNITS, TY_CHAR) + + # Get the input image data type. + iferr { + call cq_dgwrd (cq, CQ_CATNO(cq), "wcs", Memc[value], + CQ_SZ_QPVALUE) + } then { + CQ_IMTYPE(res) = CQ_WNONE + } else { + CQ_WCS(res) = strdic (Memc[value], Memc[value], CQ_SZ_QPVALUE, + CQ_WTYPESTR) + } + + # Get the number of wcs parameters. + iferr (CQ_NWCS(res) = cq_dgeti (cq, CQ_CATNO(cq), "nwcs")) + CQ_NWCS(res) = 0 + + # Allocate space for the wcs parameters. + call calloc (CQ_WPNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_WKNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_WKDVALUES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_WKVALUES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_WKTYPES(res), CQ_NWCS(res), TY_INT) + call calloc (CQ_WKUNITS(res), SZ_LINE, TY_CHAR) + + # Get the wcs parameters. + ncount = 0 + if (CQ_NWCS(res) > 0) { + + # Initialize the header parameter keywords and values. + sz1 = SZ_LINE; op1 = 2 + sz2 = SZ_LINE; op2 = 2 + sz3 = SZ_LINE; op3 = 2 + sz4 = SZ_LINE; op4 = 2 + sz5 = SZ_LINE; op5 = 2 + call strcpy ("|", Memc[CQ_WPNAMES(res)], sz1) + call strcpy ("|", Memc[CQ_WKNAMES(res)], sz2) + call strcpy ("|", Memc[CQ_WKDVALUES(res)], sz3) + call strcpy ("|", Memc[CQ_WKVALUES(res)], sz4) + call strcpy ("|", Memc[CQ_WKUNITS(res)], sz5) + + + do i = 1, CQ_NWCS(res) { + + # Get the wcs parameter name, keyword, default value, + # data type and units value. + if (cq_dscan (cq) == EOF) + break + call gargwrd (Memc[wpname], CQ_SZ_QPNAME) + call gargwrd (Memc[wkname], CQ_SZ_QPNAME) + call gargwrd (Memc[wkdvalue], CQ_SZ_QPVALUE) + call gargc (ftype) + call gargwrd (Memc[wkunits], CQ_SZ_QPUNITS) + if (nscan() != 5) + break + + # Add the parameter name to the list. + if ((sz1 - op1 + 1) < (CQ_SZ_QPNAME + 1)) { + sz1 = sz1 + SZ_LINE + call realloc (CQ_WPNAMES(res), sz1, TY_CHAR) + } + op1 = op1 + gstrcpy (Memc[wpname], Memc[CQ_WPNAMES(res)+op1-1], + sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[CQ_WPNAMES(res)+op1-1], + sz1 - op1 + 1) + + # Add the keyword name to the list. + if ((sz2 - op2 + 1) < (CQ_SZ_QPNAME + 1)) { + sz2 = sz2 + SZ_LINE + call realloc (CQ_WKNAMES(res), sz2, TY_CHAR) + } + op2 = op2 + gstrcpy (Memc[wkname], Memc[CQ_WKNAMES(res)+op2-1], + sz2 - op2 + 1) + op2 = op2 + gstrcpy ("|", Memc[CQ_WKNAMES(res)+op2-1], + sz2 - op2 + 1) + + # Add the default keyword value to the list. + if ((sz3 - op3 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz3 = sz3 + SZ_LINE + call realloc (CQ_WKDVALUES(res), sz3, TY_CHAR) + } + op3 = op3 + gstrcpy (Memc[wkdvalue], + Memc[CQ_WKDVALUES(res)+op3-1], sz3 - op3 + 1) + op3 = op3 + gstrcpy ("|", Memc[CQ_WKDVALUES(res)+op3-1], + sz3 - op3 + 1) + + # Add the keyword value to the list. + if ((sz4 - op4 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz4 = sz4 + SZ_LINE + call realloc (CQ_WKVALUES(res), sz4, TY_CHAR) + } + op4 = op4 + gstrcpy (Memc[wkdvalue], + Memc[CQ_WKVALUES(res)+op4-1], sz4 - op4 + 1) + op4 = op4 + gstrcpy ("|", Memc[CQ_WKVALUES(res)+op4-1], + sz4 - op4 + 1) + + # Compute the data type. + Memi[CQ_WKTYPES(res)+i-1] = cq_dtype (ftype) + + # Add the default keyword value to the list. + if ((sz5 - op5 + 1) < (CQ_SZ_QPUNITS + 1)) { + sz5 = sz5 + SZ_LINE + call realloc (CQ_WKUNITS(res), sz5, TY_CHAR) + } + op5 = op5 + gstrcpy (Memc[wkunits], + Memc[CQ_WKUNITS(res)+op5-1], sz5 - op5 + 1) + op5 = op5 + gstrcpy ("|", Memc[CQ_WKUNITS(res)+op5-1], + sz5 - op5 + 1) + + ncount = ncount + 1 + } + } + + # Resize the wcs parameter arrays. + if (ncount != CQ_NWCS(res)) { + CQ_NWCS(res) = 0 + call realloc (CQ_WPNAMES(res), 1, TY_CHAR) + call realloc (CQ_WKNAMES(res), 1, TY_CHAR) + call realloc (CQ_WKDVALUES(res), 1, TY_CHAR) + call realloc (CQ_WKVALUES(res), 1, TY_CHAR) + call mfree (CQ_WKTYPES(res), TY_INT) + CQ_WKTYPES(res) = NULL + call realloc (CQ_WKUNITS(res), 1, TY_CHAR) + } else { + call realloc (CQ_WPNAMES(res), op1, TY_CHAR) + call realloc (CQ_WKNAMES(res), op2, TY_CHAR) + call realloc (CQ_WKDVALUES(res), op3, TY_CHAR) + call realloc (CQ_WKVALUES(res), op4, TY_CHAR) + call realloc (CQ_WKUNITS(res), op5, TY_CHAR) + Memc[CQ_WPNAMES(res)+op1] = EOS + Memc[CQ_WKNAMES(res)+op2] = EOS + Memc[CQ_WKDVALUES(res)+op3] = EOS + Memc[CQ_WKVALUES(res)+op4] = EOS + Memc[CQ_WKUNITS(res)+op5] = EOS + } + + # Get the number of keyword parameters. + iferr (CQ_NIMPARS(res) = cq_dgeti (cq, CQ_CATNO(cq), "nkeys")) + CQ_NIMPARS(res) = 0 + + # Allocate space for the keyword parameters. + call calloc (CQ_IPNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_IKNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_IKDVALUES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_IKVALUES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_IKTYPES(res), CQ_NIMPARS(res), TY_INT) + call calloc (CQ_IKUNITS(res), SZ_LINE, TY_CHAR) + + # Get the keyword parameters. + ncount = 0 + if (CQ_NIMPARS(res) > 0) { + + # Initialize the header parameter keywords and values. + sz1 = SZ_LINE; op1 = 2 + sz2 = SZ_LINE; op2 = 2 + sz3 = SZ_LINE; op3 = 2 + sz4 = SZ_LINE; op4 = 2 + sz5 = SZ_LINE; op5 = 2 + call strcpy ("|", Memc[CQ_IPNAMES(res)], sz1) + call strcpy ("|", Memc[CQ_IKNAMES(res)], sz2) + call strcpy ("|", Memc[CQ_IKDVALUES(res)], sz3) + call strcpy ("|", Memc[CQ_IKVALUES(res)], sz4) + call strcpy ("|", Memc[CQ_IKUNITS(res)], sz5) + + do i = 1, CQ_NIMPARS(res) { + + # Get the wcs parameter name, keyword, default value, + # data type and units value. + if (cq_dscan (cq) == EOF) + break + call gargwrd (Memc[wpname], CQ_SZ_QPNAME) + call gargwrd (Memc[wkname], CQ_SZ_QPNAME) + call gargwrd (Memc[wkdvalue], CQ_SZ_QPVALUE) + call gargc (ftype) + call gargwrd (Memc[wkunits], CQ_SZ_QPUNITS) + if (nscan() != 5) + break + + # Add the parameter name to the list. + if ((sz1 - op1 + 1) < (CQ_SZ_QPNAME + 1)) { + sz1 = sz1 + SZ_LINE + call realloc (CQ_IPNAMES(res), sz1, TY_CHAR) + } + op1 = op1 + gstrcpy (Memc[wpname], Memc[CQ_IPNAMES(res)+op1-1], + sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[CQ_IPNAMES(res)+op1-1], + sz1 - op1 + 1) + + # Add the keyword name to the list. + if ((sz2 - op2 + 1) < (CQ_SZ_QPNAME + 1)) { + sz2 = sz2 + SZ_LINE + call realloc (CQ_IKNAMES(res), sz2, TY_CHAR) + } + op2 = op2 + gstrcpy (Memc[wkname], Memc[CQ_IKNAMES(res)+op2-1], + sz2 - op2 + 1) + op2 = op2 + gstrcpy ("|", Memc[CQ_IKNAMES(res)+op2-1], + sz2 - op2 + 1) + + # Add the default keyword value to the list. + if ((sz3 - op3 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz3 = sz3 + SZ_LINE + call realloc (CQ_IKDVALUES(res), sz3, TY_CHAR) + } + op3 = op3 + gstrcpy (Memc[wkdvalue], + Memc[CQ_IKDVALUES(res)+op3-1], sz3 - op3 + 1) + op3 = op3 + gstrcpy ("|", Memc[CQ_IKDVALUES(res)+op3-1], + sz3 - op3 + 1) + + # Add the keyword value to the list. + if ((sz4 - op4 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz4 = sz4 + SZ_LINE + call realloc (CQ_IKVALUES(res), sz4, TY_CHAR) + } + op4 = op4 + gstrcpy (Memc[wkdvalue], + Memc[CQ_IKVALUES(res)+op4-1], sz4 - op4 + 1) + op4 = op4 + gstrcpy ("|", Memc[CQ_IKVALUES(res)+op4-1], + sz4 - op4 + 1) + + # Compute the data type. + Memi[CQ_IKTYPES(res)+i-1] = cq_dtype (ftype) + + # Add the default keyword value to the list. + if ((sz5 - op5 + 1) < (CQ_SZ_QPUNITS + 1)) { + sz5 = sz5 + SZ_LINE + call realloc (CQ_IKUNITS(res), sz5, TY_CHAR) + } + op5 = op5 + gstrcpy (Memc[wkunits], + Memc[CQ_IKUNITS(res)+op5-1], sz5 - op5 + 1) + op5 = op5 + gstrcpy ("|", Memc[CQ_IKUNITS(res)+op5-1], + sz5 - op5 + 1) + + ncount = ncount + 1 + + } + } + + # Resize the wcs parameter arrays. + if (ncount != CQ_NIMPARS(res)) { + CQ_NIMPARS(res) = 0 + call realloc (CQ_IPNAMES(res), 1, TY_CHAR) + call realloc (CQ_IKNAMES(res), 1, TY_CHAR) + call realloc (CQ_IKDVALUES(res), 1, TY_CHAR) + call realloc (CQ_IKVALUES(res), 1, TY_CHAR) + call mfree (CQ_IKTYPES(res), TY_INT) + CQ_IKTYPES(res) = NULL + call realloc (CQ_IKUNITS(res), 1, TY_CHAR) + } else { + call realloc (CQ_IPNAMES(res), op1, TY_CHAR) + call realloc (CQ_IKNAMES(res), op2, TY_CHAR) + call realloc (CQ_IKDVALUES(res), op3, TY_CHAR) + call realloc (CQ_IKVALUES(res), op4, TY_CHAR) + call realloc (CQ_IKUNITS(res), op5, TY_CHAR) + Memc[CQ_IPNAMES(res)+op1] = EOS + Memc[CQ_IKNAMES(res)+op2] = EOS + Memc[CQ_IKDVALUES(res)+op3] = EOS + Memc[CQ_IKVALUES(res)+op4] = EOS + Memc[CQ_IKUNITS(res)+op5] = EOS + } + + call sfree (sp) + + return (res) +end + + +# CQ_IRFREE -- Free the image results structure. + +procedure cq_irfree (res) + +pointer res #U the results descriptor. + +begin + # Free the query parameter names, values, and units. + if (CQ_IQPNAMES(res) != NULL) + call mfree (CQ_IQPNAMES(res), TY_CHAR) + if (CQ_IQPVALUES(res) != NULL) + call mfree (CQ_IQPVALUES(res), TY_CHAR) + if (CQ_IQPUNITS(res) != NULL) + call mfree (CQ_IQPUNITS(res), TY_CHAR) + + # Free the wcs parameters. + if (CQ_WPNAMES(res) != NULL) + call mfree (CQ_WPNAMES(res), TY_CHAR) + if (CQ_WKNAMES(res) != NULL) + call mfree (CQ_WKNAMES(res), TY_CHAR) + if (CQ_WKDVALUES(res) != NULL) + call mfree (CQ_WKDVALUES(res), TY_CHAR) + if (CQ_WKVALUES(res) != NULL) + call mfree (CQ_WKVALUES(res), TY_CHAR) + if (CQ_WKTYPES(res) != NULL) + call mfree (CQ_WKTYPES(res), TY_INT) + if (CQ_WKUNITS(res) != NULL) + call mfree (CQ_WKUNITS(res), TY_CHAR) + + # Free the image keyword parameters. + if (CQ_IPNAMES(res) != NULL) + call mfree (CQ_IPNAMES(res), TY_CHAR) + if (CQ_IKNAMES(res) != NULL) + call mfree (CQ_IKNAMES(res), TY_CHAR) + if (CQ_IKDVALUES(res) != NULL) + call mfree (CQ_IKDVALUES(res), TY_CHAR) + if (CQ_IKVALUES(res) != NULL) + call mfree (CQ_IKVALUES(res), TY_CHAR) + if (CQ_IKTYPES(res) != NULL) + call mfree (CQ_IKTYPES(res), TY_INT) + if (CQ_IKUNITS(res) != NULL) + call mfree (CQ_IKUNITS(res), TY_CHAR) + + if (res != NULL) + call mfree (res, TY_STRUCT) +end diff --git a/pkg/xtools/catquery/cqistat.x b/pkg/xtools/catquery/cqistat.x new file mode 100644 index 00000000..0ae35527 --- /dev/null +++ b/pkg/xtools/catquery/cqistat.x @@ -0,0 +1,161 @@ +include "cqdef.h" +include "cq.h" + + +# CQ_ISTATI -- Get an integer image results parameter. + +int procedure cq_istati (res, param) + +pointer res #I pointer to the results descriptor +int param #I the integer parameter to be retrieved + +begin + switch (param) { + case CQINQPARS: + return (CQ_INQPARS(res)) + case CQIMTYPE: + return (CQ_IMTYPE(res)) + case CQWCS: + return (CQ_WCS(res)) + case CQNWCS: + return (CQ_NWCS(res)) + case CQNIMPARS: + return (CQ_NIMPARS(res)) + default: + call error (0, "Error fetching integer image results parameter") + } +end + + +# CQ_ISTATR -- Get a real image results parameter. + +real procedure cq_istatr (res, param) + +pointer res #I pointer to the image results descriptor +int param #I the real image parameter to be retrieved + +begin + switch (param) { + default: + call error (0, "Error fetching real results parameter") + } +end + + +# CQ_ISTATD -- Get a double precision image results parameter. + +double procedure cq_istatd (res, param) + +pointer res #I pointer to the image results descriptor +int param #I the double parameter to be retrieved + +begin + switch (param) { + default: + call error (0, "Error fetching double results parameter") + } +end + + +# CQ_ISTATS -- Get a string image results parameter. + +procedure cq_istats (res, param, str, maxch) + +pointer res #I pointer to the results descriptor +int param #I the string parameter to be retrieved +char str[ARB] #O the output string parameter +int maxch #I the maximum size of the string parameter + +begin + switch (param) { + case CQIQPNAMES: + call strcpy (Memc[CQ_IQPNAMES(res)], str, maxch) + case CQIQPVALUES: + call strcpy (Memc[CQ_IQPVALUES(res)], str, maxch) + case CQIQPUNITS: + call strcpy (Memc[CQ_IQPUNITS(res)], str, maxch) + case CQIMCATDB: + call strcpy (CQ_IMCATDB(res), str, maxch) + case CQIMCATNAME: + call strcpy (CQ_IMCATNAME(res), str, maxch) + case CQIMADDRESS: + call strcpy (CQ_IMADDRESS(res), str, maxch) + case CQIMQUERY: + call strcpy (CQ_IMQUERY(res), str, maxch) + case CQIMNAME: + call strcpy (CQ_IMNAME(res), str, maxch) + default: + call error (0, "Error fetching string results parameter") + } +end + + +# CQ_ISTATT -- Get a text list results parameter. A text list is a +# string with items separated from each other by newlines. + +int procedure cq_istatt (res, param, str, maxch) + +pointer res #I pointer to the results descriptor +int param #I the list parameter to be retrieved +char str[ARB] #O the output string parameter +int maxch #I the maximum size of the string parameter + +pointer sp, tstr +int i, fd +int stropen(), cq_wrdstr() + +begin + switch (param) { + + case CQIQPNAMES: + call smark (sp) + call salloc (tstr, CQ_SZ_QPNAME, TY_CHAR) + fd = stropen (str, maxch, NEW_FILE) + str[1] = EOS + do i = 1, CQ_INQPARS(res) { + if (cq_wrdstr (i, Memc[tstr], CQ_SZ_QPNAME, + Memc[CQ_IQPNAMES(res)]) > 0) { + call fprintf (fd, "%s\n") + call pargstr (Memc[tstr]) + } + } + call close (fd) + call sfree (sp) + return (CQ_INQPARS(res)) + + case CQIQPVALUES: + call smark (sp) + call salloc (tstr, CQ_SZ_QPVALUE, TY_CHAR) + fd = stropen (str, maxch, NEW_FILE) + str[1] = EOS + do i = 1, CQ_INQPARS(res) { + if (cq_wrdstr (i, Memc[tstr], CQ_SZ_QPVALUE, + Memc[CQ_IQPVALUES(res)]) > 0) { + call fprintf (fd, "%s\n") + call pargstr (Memc[tstr]) + } + } + call close (fd) + call sfree (sp) + return (CQ_INQPARS(res)) + + case CQIQPUNITS: + call smark (sp) + call salloc (tstr, CQ_SZ_QPUNITS, TY_CHAR) + fd = stropen (str, maxch, NEW_FILE) + str[1] = EOS + do i = 1, CQ_INQPARS(res) { + if (cq_wrdstr (i, Memc[tstr], CQ_SZ_QPUNITS, + Memc[CQ_IQPUNITS(res)]) > 0) { + call fprintf (fd, "%s\n") + call pargstr (Memc[tstr]) + } + } + call close (fd) + call sfree (sp) + return (CQ_INQPARS(res)) + + default: + call error (0, "Error fetching list image results parameter") + } +end diff --git a/pkg/xtools/catquery/cqlocate.x b/pkg/xtools/catquery/cqlocate.x new file mode 100644 index 00000000..7070f8c0 --- /dev/null +++ b/pkg/xtools/catquery/cqlocate.x @@ -0,0 +1,40 @@ +include "cqdef.h" + +# CQ_LOCATE -- Locate a catalog by name. Return 0 if the catalog is not found. + +int procedure cq_locate (cq, name) + +pointer cq #I the catalog descriptor +char name[ARB] #I the catalog name + +int i +bool streq() + +begin + do i = 1, CQ_NRECS(cq) { + if (streq (name, CQ_NAME(cq, i))) + return (i) + } + + return (0) +end + + +# CQ_LOCATEN -- Locate a catalog by number and retrieve its name. Return 0 if +# the catalog is not found. + +int procedure cq_locaten (cq, catno, name, maxch) + +pointer cq #I the catalog descriptor +int catno #I the catalog sequence record number +char name[ARB] #O the output catalog name +int maxch #I the maximum size of the catalog name + +begin + if (catno > 0 && catno <= CQ_NRECS(cq)) { + call strcpy (CQ_NAME(cq, catno), name, maxch) + return (catno) + } + + return (0) +end diff --git a/pkg/xtools/catquery/cqmap.x b/pkg/xtools/catquery/cqmap.x new file mode 100644 index 00000000..75ad4c2f --- /dev/null +++ b/pkg/xtools/catquery/cqmap.x @@ -0,0 +1,112 @@ +include <ctype.h> +include "cqdef.h" + +# CQ_MAP -- Map a catalog database. + +pointer procedure cq_map (database, mode) + +char database[ARB] #I The database file +int mode #I The database file access mode + +int i, nrec, cq_alloc1, cq_alloc2 +pointer cq, str + +long note() +int open(), fscan(), strlen() +bool streq() +errchk open() + +begin + if (mode != READ_ONLY && mode != NEW_FILE && mode != APPEND) + return (NULL) + + iferr (i = open (database, mode, TEXT_FILE)) + return (NULL) + + call calloc (cq, CQ_LEN, TY_STRUCT) + call strcpy (database, CQ_CATDB(cq), SZ_FNAME) + CQ_FD(cq) = i + + if (mode != READ_ONLY) + return (cq) + + cq_alloc1 = CQ_ALLOC + cq_alloc2 = CQ_ALLOC * SZ_LINE + call malloc (CQ_OFFSETS(cq), cq_alloc1, TY_LONG) + call malloc (CQ_NAMES(cq), cq_alloc1, TY_INT) + call malloc (CQ_MAP(cq), cq_alloc2, TY_CHAR) + call malloc (str, SZ_LINE, TY_CHAR) + + nrec = 1 + CQ_NRECS(cq) = 0 + CQ_NAMEI(cq, nrec) = 0 + + while (fscan (CQ_FD(cq)) != EOF) { + call gargwrd (CQ_NAME(cq, nrec), SZ_LINE) + + if (streq (CQ_NAME(cq, nrec), "begin")) { + call gargstr (Memc[str], SZ_LINE) + for (i=str; IS_WHITE(Memc[i]); i=i+1) + ; + call strcpy (Memc[i], CQ_NAME(cq,nrec), SZ_LINE) + + for (i = 1; i < nrec; i = i + 1) + if (streq (CQ_NAME(cq, i), CQ_NAME(cq, nrec))) + break + + if (i < nrec) + CQ_OFFSET(cq, i) = note (CQ_FD(cq)) + else { + CQ_NRECS(cq) = nrec + CQ_OFFSET(cq, nrec) = note (CQ_FD(cq)) + CQ_NAMEI(cq, nrec+1) = CQ_NAMEI(cq, nrec) + + strlen (CQ_NAME(cq, nrec)) + 1 + nrec = nrec + 1 + } + + if (nrec == cq_alloc1) { + cq_alloc1 = cq_alloc1 + CQ_ALLOC + call realloc (CQ_OFFSETS(cq), cq_alloc1, TY_LONG) + call realloc (CQ_NAMES(cq), cq_alloc1, TY_INT) + } + if (CQ_NAMEI(cq, nrec) + SZ_LINE >= cq_alloc2) { + cq_alloc2 = cq_alloc2 + CQ_ALLOC * SZ_LINE + call realloc (CQ_MAP(cq), cq_alloc2, TY_CHAR) + } + } + } + + call realloc (CQ_MAP(cq), CQ_NAMEI(cq, nrec), TY_CHAR) + call realloc (CQ_OFFSETS(cq), CQ_NRECS(cq), TY_LONG) + call realloc (CQ_NAMES(cq), CQ_NRECS(cq), TY_INT) + call mfree (str, TY_CHAR) + + return (cq) +end + + +# CQ_UNMAP -- Close the database. + +procedure cq_unmap (cq) + +pointer cq #U The database file descriptor + +begin + if (cq == NULL) + return + + # Free the current catalog structure. + call cq_ccfree (cq) + + # Close the catalog database file. + if (CQ_FD(cq) != NULL) + call close (CQ_FD(cq)) + + # Free the record mapping arrays. + call mfree (CQ_MAP(cq), TY_CHAR) + call mfree (CQ_OFFSETS(cq), TY_LONG) + call mfree (CQ_NAMES(cq), TY_INT) + + # Free the structure. + call mfree (cq, TY_STRUCT) +end diff --git a/pkg/xtools/catquery/cqnqpars.x b/pkg/xtools/catquery/cqnqpars.x new file mode 100644 index 00000000..d7769925 --- /dev/null +++ b/pkg/xtools/catquery/cqnqpars.x @@ -0,0 +1,18 @@ +include "cqdef.h" + + +# CQ_NQPARS -- Return the number of query parameters. Do we really need +# a special routine ? + +int procedure cq_nqpars (cq) + +pointer cq #I the catalog descriptor + +begin + if (CQ_CAT(cq) == NULL) + return (0) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (0) + + return (CQ_NQPARS(CQ_CAT(cq))) +end diff --git a/pkg/xtools/catquery/cqquery.x b/pkg/xtools/catquery/cqquery.x new file mode 100644 index 00000000..1806484c --- /dev/null +++ b/pkg/xtools/catquery/cqquery.x @@ -0,0 +1,998 @@ +include <fset.h> +include <ctype.h> +include "cqdef.h" +include "cq.h" + + +define DEF_SZ_INBUF 32768 # the maximum network transfer buffer size +define DEF_SZ_INDEX 1000 # the record index length increment + +# CQ_QUERY -- Send a query and return the data. + +pointer procedure cq_query (cq) + +pointer cq #I the catalog database descriptor + +pointer cc, res, inbuf, line, sp, spfname +char url[SZ_PATHNAME], addr[SZ_LINE], query[SZ_LINE], buf[SZ_LINE] +int j, fd, nchars, nlines, nrecs, szindex, ip, op +bool done +long note() +pointer cq_rinit() +int ndopen(), strlen(), read(), open(), getline(), fstati(), url_get() +errchk ndopen(), fprintf(), areadb(), awriteb(), open(), read() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (NULL) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (NULL) + cc = CQ_CAT(cq) + + + if (0<1&& USE_URLGET) { + # Initialize the image results structure. + res = cq_rinit (cq) + + call strcpy (CQ_ADDRESS(cc), buf, SZ_LINE) + for (ip=1; buf[ip] != ':'; ip=ip+1) ; # skip 'inet:' + ip = ip + 1 + for ( ; buf[ip] != ':'; ip=ip+1) ; # skip '80:' + ip = ip + 1 + for (op=1; buf[ip] != ':'; ip=ip+1) { + addr[op] = buf[ip] + op = op + 1 + } + addr[op] = EOS + + call strcpy (CQ_RQUERY(res), buf, SZ_LINE) + for (op=1; !IS_WHITE(buf[op+4]); op=op+1) + query[op] = buf[op+4] + query[op] = EOS + + call sprintf (url, SZ_LINE, "http://%s%s") + call pargstr (addr) + call pargstr (query) + + iferr { + call smark (sp) + call salloc (spfname, SZ_FNAME, TY_CHAR) + + call malloc (inbuf, DEF_SZ_INBUF, TY_CHAR) + + # Open the output spool file. + call mktemp ("query", Memc[spfname], SZ_FNAME) + + if (url_get (url, Memc[spfname], inbuf) < 0) + call error (0, "Cannot access url") + + fd = open (Memc[spfname], READ_ONLY, TEXT_FILE) + CQ_RFD(res) = open (Memc[spfname], READ_WRITE, SPOOL_FILE) + repeat { + call aclrc (Memc[inbuf], DEF_SZ_INBUF) + nchars = read (fd, Memc[inbuf], DEF_SZ_INBUF) + if (nchars > 0) { + Memc[inbuf+nchars] = EOS + call write (CQ_RFD(res), Memc[inbuf], nchars) + done = false + } else + done = true + } until (done) + call flush (CQ_RFD(res)) + call close (fd) + + CQ_RBUF(res) = fstati (CQ_RFD(res), F_BUFPTR) + call seek (CQ_RFD(res), BOF) + + call mfree (inbuf, TY_CHAR) + call sfree (sp) + + } then { + if (res != NULL) + call cq_rfree (res) + return (NULL) + } + + } else { + + # Open the network connection. + iferr (fd = ndopen (CQ_ADDRESS(cc), READ_WRITE)) + return (NULL) + + # Initialize the results structure. + res = cq_rinit (cq) + + # Send the query and get back the results. + iferr { + + call smark (sp) + + # Formulate the query. + switch (CQ_RTYPE(res)) { + case CQ_STEXT, CQ_BTEXT: + call fprintf (fd, "%s") + call pargstr (CQ_RQUERY(res)) + default: + nchars = strlen (CQ_RQUERY(res)) + call write (fd, CQ_RQUERY(res), nchars) + } + call flush (fd) + + # Open the output spool file. + call salloc (spfname, SZ_FNAME, TY_CHAR) + call mktemp ("query", Memc[spfname], SZ_FNAME) + CQ_RFD(res) = open (Memc[spfname], READ_WRITE, SPOOL_FILE) + call sfree (sp) + + # Get the data. + call malloc (inbuf, DEF_SZ_INBUF, TY_CHAR) + call fseti (fd, F_CANCEL, OK) + + switch (CQ_HFMT(cc)) { + case CQ_HNONE: + ; + case CQ_HHTTP: + repeat { + nchars = getline (fd, Memc[inbuf]) + if (nchars <= 0) + break + Memc[inbuf+nchars] = EOS + } until ((Memc[inbuf] == '\r' && Memc[inbuf+1] == '\n') || + (Memc[inbuf] == '\n')) + default: + ; + } + + repeat { + nchars = read (fd, Memc[inbuf], DEF_SZ_INBUF) + if (nchars > 0) { + Memc[inbuf+nchars] = EOS + call write (CQ_RFD(res), Memc[inbuf], nchars) + done = false + } else { + done = true + } + } until (done) + + # Cleanup. + call flush (CQ_RFD(res)) + call mfree (inbuf, TY_CHAR) + CQ_RBUF(res) = fstati (CQ_RFD(res), F_BUFPTR) + call seek (CQ_RFD(res), BOF) + call close (fd) + + } then { + call cq_rfree (res) + call close (fd) + return (NULL) + } + + } + + # Construct the record index. + CQ_RNRECS(res) = 0 + switch (CQ_RTYPE(res)) { + case CQ_STEXT, CQ_BTEXT: + + # Initialize. + nlines = 0 + nrecs = 0 + + # Iniitialize the index array. + szindex = DEF_SZ_INDEX + call malloc (line, SZ_LINE, TY_CHAR) + call calloc (CQ_RINDEX(res), szindex, TY_LONG) + + # Create the index array. + repeat { + Meml[CQ_RINDEX(res)+nrecs] = note (CQ_RFD(res)) + nchars = getline (CQ_RFD(res), Memc[line]) + if (nchars == EOF) + break + nlines = nlines + 1 + if (nlines <= CQ_RHSKIP(res)) + next + if (Memc[line] == '\n') + next + #if (CQ_RECSIZE(res) > 0 && nchars != CQ_RECSIZE(res)) + if (CQ_RECSIZE(res) > 0 && nchars > CQ_RECSIZE(res)) + Meml[CQ_RINDEX(res)+nrecs] = EOF + else if (CQ_RTRIML(res) > 0 || CQ_RTRIMR(res) > 0) { + inbuf = CQ_RBUF(res) + Meml[CQ_RINDEX(res)+nrecs] - 1 + do j = 1, min (CQ_RTRIML(res), nchars) + Memc[inbuf+j-1] = ' ' + do j = nchars - CQ_RTRIMR(res), nchars - 1 + Memc[inbuf+j-1] = ' ' + } + nrecs = nrecs + 1 + if (nrecs >= szindex) { + szindex = szindex + DEF_SZ_INDEX + call realloc (CQ_RINDEX(res), szindex, TY_LONG) + call aclrl (Meml[CQ_RINDEX(res)+szindex-DEF_SZ_INDEX], + DEF_SZ_INDEX) + } + } + call mfree (line, TY_CHAR) + CQ_RNRECS(res) = nrecs + + # Remove the incorrectly sized and trailing records. + nrecs = 0 + do j = 0, CQ_RNRECS(res) - CQ_RTSKIP(res) - 1 { + if (Meml[CQ_RINDEX(res)+j] == EOF) + next + Meml[CQ_RINDEX(res)+nrecs] = Meml[CQ_RINDEX(res)+j] + nrecs = nrecs + 1 + } + CQ_RNRECS(res) = nrecs + + # Resize the index array. + call realloc (CQ_RINDEX(res), max (1, CQ_RNRECS(res) + 1), TY_LONG) + + default: + ; + } + + # Return the results pointer. + return (res) +end + + +# CQ_FQUERY -- Treat a catalog file file as thought it were the results +# of a query. The catalog file file name and file description are passed +# to the routine as arguments. + +pointer procedure cq_fquery (cq, catfile, catfmt) + +pointer cq #I the catalog database descriptor +char catfile[ARB] #I the input catalog file +char catfmt[ARB] #I the input catalog description + +pointer res, inbuf, line, sp, spfname +int j, fd, nchars, nlines, nrecs, szindex +bool done +pointer cq_frinit() +long note() +int access(), open(), read(), fstati(), getline() +errchk open(), read() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (NULL) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (NULL) + + # Check to see if the catalog file exists. + if (access (catfile, 0, 0) == NO) + return (NULL) + + # Check to see if the fmt string is defined. + if (catfmt[1] == EOS) + return (NULL) + + # Open the catalog file. + if (access (catfile, READ_ONLY, TEXT_FILE) == YES) { + iferr (fd = open (catfile, READ_ONLY, TEXT_FILE)) + return (NULL) + } else { + iferr (fd = open (catfile, READ_ONLY, BINARY_FILE)) + return (NULL) + } + + # Initialize the results structure using the file description. + res = cq_frinit (cq, catfmt) + if (res == NULL) + return (NULL) + + # Read in the results. + iferr { + + # Open the output spool file. + call smark (sp) + call salloc (spfname, SZ_FNAME, TY_CHAR) + call mktemp ("query", Memc[spfname], SZ_FNAME) + #CQ_RFD(res) = open ("dev$null", READ_WRITE, SPOOL_FILE) + CQ_RFD(res) = open (Memc[spfname], READ_WRITE, SPOOL_FILE) + call sfree (sp) + + # Get the data. + call malloc (inbuf, DEF_SZ_INBUF, TY_CHAR) + repeat { + nchars = read (fd, Memc[inbuf], DEF_SZ_INBUF) + if (nchars > 0) { + Memc[inbuf+nchars] = EOS + call write (CQ_RFD(res), Memc[inbuf], nchars) + done = false + } else { + done = true + } + } until (done) + + # Cleanup. + call flush (CQ_RFD(res)) + call mfree (inbuf, TY_CHAR) + CQ_RBUF(res) = fstati (CQ_RFD(res), F_BUFPTR) + call close (fd) + + } then { + call cq_rfree (res) + call close (fd) + return (NULL) + } + + # Construct the record index. + CQ_RNRECS(res) = 0 + switch (CQ_RTYPE(res)) { + case CQ_STEXT, CQ_BTEXT: + + # Initialize. + nlines = 0 + nrecs = 0 + + # Iniitialize the index array. + szindex = DEF_SZ_INDEX + call malloc (line, SZ_LINE, TY_CHAR) + call calloc (CQ_RINDEX(res), szindex, TY_LONG) + + # Create the index array. + call seek (CQ_RFD(res), BOF) + repeat { + Meml[CQ_RINDEX(res)+nrecs] = note (CQ_RFD(res)) + nchars = getline (CQ_RFD(res), Memc[line]) + if (nchars == EOF) + break + nlines = nlines + 1 + if (nlines <= CQ_RHSKIP(res)) + next + if (Memc[line] == '\n') + next + if (Memc[line] == '#') + next + #if (CQ_RECSIZE(res) > 0 && nchars != CQ_RECSIZE(res)) + if (CQ_RECSIZE(res) > 0 && nchars > CQ_RECSIZE(res)) + Meml[CQ_RINDEX(res)+nrecs] = EOF + else if (CQ_RTRIML(res) > 0 || CQ_RTRIMR(res) > 0) { + inbuf = CQ_RBUF(res) + Meml[CQ_RINDEX(res)+nrecs] - 1 + do j = 1, min (CQ_RTRIML(res), nchars) + Memc[inbuf+j-1] = ' ' + do j = nchars - CQ_RTRIMR(res), nchars - 1 + Memc[inbuf+j-1] = ' ' + } + nrecs = nrecs + 1 + if (nrecs >= szindex) { + szindex = szindex + DEF_SZ_INDEX + call realloc (CQ_RINDEX(res), szindex, TY_LONG) + call aclrl (Meml[CQ_RINDEX(res)+szindex-DEF_SZ_INDEX], + DEF_SZ_INDEX) + } + } + call mfree (line, TY_CHAR) + CQ_RNRECS(res) = nrecs + + # Check for and reject short records and trim trailing records. + nrecs = 0 + do j = 0, CQ_RNRECS(res) - CQ_RTSKIP(res) - 1 { + if (Meml[CQ_RINDEX(res)+j] == EOF) + next + Meml[CQ_RINDEX(res)+nrecs] = Meml[CQ_RINDEX(res)+j] + nrecs = nrecs + 1 + } + CQ_RNRECS(res) = nrecs + + # Trim the trailing records. + call realloc (CQ_RINDEX(res), max (1, CQ_RNRECS(res) + 1), TY_LONG) + + default: + ; + } + + return (res) +end + + +# CQ_RCLOSE -- Close the results structure, + +procedure cq_rclose (res) + +pointer res #U the results descriptor. + +begin + call cq_rfree (res) +end + + +# CQ_RINIT -- Initialize a results descriptor. + +pointer procedure cq_rinit (cq) + +pointer cq #I the catalog descriptor + +pointer cc, res, sp, query, value, kname, fname, funits, ffmt +int i, ncount, sz1, sz2, sz3, op1, op2, op3, foffset, fsize +char ftype +int cq_wrdstr(), strdic(), cq_dgeti(), cq_dscan(), nscan() +int cq_dtype(), strlen(), gstrcpy() +errchk cq_dgwrd(), cq_dgeti(), cq_dscan() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (NULL) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (NULL) + cc = CQ_CAT(cq) + + # Allocate the results structure. + call calloc (res, CQ_LEN_RES, TY_STRUCT) + + # Format the query. + call smark (sp) + call salloc (query, SZ_LINE, TY_CHAR) + call salloc (value, CQ_SZ_QPVALUE, TY_CHAR) + call sprintf (Memc[query], SZ_LINE, CQ_QUERY(cc)) + do i = 1, CQ_NQPARS(cc) { + if (cq_wrdstr (i, Memc[value], CQ_SZ_QPVALUE, + Memc[CQ_PQPVALUES(cc)]) <= 0) + next + call pargstr (Memc[value]) + } + + # Save the catalog informaton and query in the results structure. + call strcpy (CQ_CATDB(cq), CQ_RCATDB(res), SZ_FNAME) + call strcpy (CQ_CATNAME(cq), CQ_RCATNAME(res), SZ_FNAME) + call strcpy (CQ_ADDRESS(cc), CQ_RADDRESS(res), SZ_LINE) + call strcpy (Memc[query], CQ_RQUERY(res), SZ_LINE) + + # Copy the query parameters to the results descriptor. + CQ_RNQPARS(res) = CQ_NQPARS(cc) + fsize = strlen (Memc[CQ_PQPNAMES(cc)]) + call malloc (CQ_RQPNAMES(res), fsize, TY_CHAR) + call strcpy (Memc[CQ_PQPNAMES(cc)], Memc[CQ_RQPNAMES(res)], fsize) + fsize = strlen (Memc[CQ_PQPVALUES(cc)]) + call malloc (CQ_RQPVALUES(res), fsize, TY_CHAR) + call strcpy (Memc[CQ_PQPVALUES(cc)], Memc[CQ_RQPVALUES(res)], fsize) + fsize = strlen (Memc[CQ_PQPUNITS(cc)]) + call malloc (CQ_RQPUNITS(res), fsize, TY_CHAR) + call strcpy (Memc[CQ_PQPUNITS(cc)], Memc[CQ_RQPUNITS(res)], fsize) + + # Get the input data type. + iferr { + call cq_dgwrd (cq, CQ_CATNO(cq), "type", Memc[value], + CQ_SZ_QPVALUE) + } then { + Memc[value] = EOS + CQ_RTYPE(res) = CQ_STEXT + } else { + CQ_RTYPE(res) = strdic (Memc[value], Memc[value], CQ_SZ_QPVALUE, + CQ_RTYPESTR) + } + + # Get the number of leading and trailing records to be skipped. + iferr (CQ_RHSKIP(res) = cq_dgeti (cq, CQ_CATNO(cq), "hskip")) + CQ_RHSKIP(res) = 0 + iferr (CQ_RTSKIP(res) = cq_dgeti (cq, CQ_CATNO(cq), "tskip")) + CQ_RTSKIP(res) = 0 + + # Get the record size and trimming parameters. + iferr (CQ_RECSIZE(res) = cq_dgeti (cq, CQ_CATNO(cq), "recsize")) + CQ_RECSIZE(res) = 0 + iferr (CQ_RTRIML(res) = cq_dgeti (cq, CQ_CATNO(cq), "triml")) + CQ_RTRIML(res) = 0 + iferr (CQ_RTRIMR(res) = cq_dgeti (cq, CQ_CATNO(cq), "trimr")) + CQ_RTRIMR(res) = 0 + + iferr (CQ_NHEADER(res) = cq_dgeti (cq, CQ_CATNO(cq), "nheader")) + CQ_NHEADER(res) = 0 + + # Get the header parameters. + call calloc (CQ_HKNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_HKVALUES(res), SZ_LINE, TY_CHAR) + ncount = 0 + if (CQ_NHEADER(res) > 0) { + + # Initialize the header parameter keywords and values. + sz1 = SZ_LINE; op1 = 2 + sz2 = SZ_LINE; op2 = 2 + call strcpy ("|", Memc[CQ_HKNAMES(res)], sz1) + call strcpy ("|", Memc[CQ_HKVALUES(res)], sz2) + + call salloc (kname, CQ_SZ_FNAME, TY_CHAR) + do i = 1, CQ_NHEADER(res) { + + # Get the keyword and value. + if (cq_dscan (cq) == EOF) + break + call gargwrd (Memc[kname], CQ_SZ_QPNAME) + call gargwrd (Memc[query], SZ_LINE) + if (nscan() != 2) + break + + # Add the keyword name to the list. + if ((sz1 - op1 + 1) < (CQ_SZ_QPNAME + 1)) { + sz1 = sz1 + SZ_LINE + call realloc (CQ_HKNAMES(res), sz1, TY_CHAR) + } + op1 = op1 + gstrcpy (Memc[kname], Memc[CQ_HKNAMES(res)+op1-1], + sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[CQ_HKNAMES(res)+op1-1], + sz1 - op1 + 1) + + # Add the keyword value to the list. + if ((sz2 - op2 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz2 = sz2 + SZ_LINE + call realloc (CQ_HKVALUES(res), sz2, TY_CHAR) + } + op2 = op2 + gstrcpy (Memc[query], Memc[CQ_HKVALUES(res)+op2-1], + sz2 - op2 + 1) + op2 = op2 + gstrcpy ("|", Memc[CQ_HKVALUES(res)+op2-1], + sz2 - op2 + 1) + + ncount = ncount + 1 + } + } + + # Resize the header keyword and value arrays. + if (ncount != CQ_NHEADER(res)) { + CQ_NHEADER(res) = 0 + call realloc (CQ_HKNAMES(res), 1, TY_CHAR) + call realloc (CQ_HKVALUES(res), 1, TY_CHAR) + Memc[CQ_HKNAMES(res)] = EOS + Memc[CQ_HKVALUES(res)] = EOS + } else { + call realloc (CQ_HKNAMES(res), op1, TY_CHAR) + call realloc (CQ_HKVALUES(res), op2, TY_CHAR) + Memc[CQ_HKNAMES(res)+op1] = EOS + Memc[CQ_HKVALUES(res)+op2] = EOS + } + + iferr (CQ_NFIELDS(res) = cq_dgeti (cq, CQ_CATNO(cq), "nfields")) + CQ_NFIELDS(res) = 0 + + # Allocate the field description arrays. + call calloc (CQ_FNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_FOFFSETS(res), CQ_NFIELDS(res), TY_INT) + call calloc (CQ_FSIZES(res), CQ_NFIELDS(res), TY_INT) + call calloc (CQ_FTYPES(res), CQ_NFIELDS(res), TY_INT) + call calloc (CQ_FUNITS(res), SZ_LINE, TY_CHAR) + call calloc (CQ_FFMTS(res), SZ_LINE, TY_CHAR) + + # Get the field decoding parameters. + ncount = 0 + if (CQ_NFIELDS(res) > 0) { + + call salloc (fname, CQ_SZ_FNAME, TY_CHAR) + call salloc (funits, CQ_SZ_FUNITS, TY_CHAR) + call salloc (ffmt, CQ_SZ_FFMTS, TY_CHAR) + + # Initialize the name, units, and format string dictionaries. + sz1 = SZ_LINE; op1 = 2 + sz2 = SZ_LINE; op2 = 2 + sz3 = SZ_LINE; op3 = 2 + call strcpy ("|", Memc[CQ_FNAMES(res)], sz1) + call strcpy ("|", Memc[CQ_FUNITS(res)], sz2) + call strcpy ("|", Memc[CQ_FFMTS(res)], sz3) + + do i =1, CQ_NFIELDS(res) { + + # Get the field description. + if (cq_dscan (cq) == EOF) + break + call gargwrd (Memc[fname], CQ_SZ_FNAME) + call gargi (foffset) + call gargi (fsize) + call gargc (ftype) + call gargwrd (Memc[funits], CQ_SZ_FUNITS) + call gargwrd (Memc[ffmt], CQ_SZ_FFMTS) + if (nscan() != 6) + break + + # Add the field name to the field name dictionary. + if ((sz1 - op1 + 1) < (CQ_SZ_FNAME + 1)) { + sz1 = sz1 + SZ_LINE + call realloc (CQ_FNAMES(res), sz1, TY_CHAR) + } + op1 = op1 + gstrcpy (Memc[fname], Memc[CQ_FNAMES(res)+op1-1], + sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[CQ_FNAMES(res)+op1-1], + sz1 - op1 + 1) + + # Set the field offset, size, and type. + Memi[CQ_FOFFSETS(res)+i-1] = foffset + Memi[CQ_FTYPES(res)+i-1] = cq_dtype (ftype) + Memi[CQ_FSIZES(res)+i-1] = fsize + + # Add the field units to the field units dictionary. + if ((sz2 - op2 + 1) < (CQ_SZ_FUNITS + 1)) { + sz2 = sz2 + SZ_LINE + call realloc (CQ_FUNITS(res), sz2, TY_CHAR) + } + op2 = op2 + gstrcpy (Memc[funits], Memc[CQ_FUNITS(res)+op2-1], + sz2 - op2 + 1) + op2 = op2 + gstrcpy ("|", Memc[CQ_FUNITS(res)+op2-1], + sz2 - op2 + 1) + + # Add the field format to the field format dictionary. + if ((sz3 - op3 + 1) < (CQ_SZ_FFMTS + 1)) { + sz3 = sz3 + SZ_LINE + call realloc (CQ_FFMTS(res), sz3, TY_CHAR) + } + op3 = op3 + gstrcpy (Memc[ffmt], Memc[CQ_FFMTS(res)+op3-1], + sz3 - op3 + 1) + op3 = op3 + gstrcpy ("|", Memc[CQ_FFMTS(res)+op3-1], + sz3 - op3 + 1) + + ncount = ncount + 1 + } + } + + # Adjust the field description size. + if (ncount != CQ_NFIELDS(res)) { + CQ_NFIELDS(res) = 0 + call realloc (CQ_FNAMES(res), 1, TY_CHAR) + Memc[CQ_FNAMES(res)] = EOS + call mfree (CQ_FOFFSETS(res), TY_INT); CQ_FOFFSETS(res) = NULL + call mfree (CQ_FSIZES(res), TY_INT); CQ_FSIZES(res) = NULL + call mfree (CQ_FTYPES(res), TY_INT); CQ_FTYPES(res) = NULL + call realloc (CQ_FUNITS(res), 1, TY_CHAR) + Memc[CQ_FUNITS(res)] = EOS + call realloc (CQ_FFMTS(res), 1, TY_CHAR) + Memc[CQ_FFMTS(res)] = EOS + } else { + call realloc (CQ_FNAMES(res), op1, TY_CHAR) + call realloc (CQ_FUNITS(res), op2, TY_CHAR) + call realloc (CQ_FFMTS(res), op3, TY_CHAR) + Memc[CQ_FNAMES(res)+op1] = EOS + Memc[CQ_FUNITS(res)+op2] = EOS + Memc[CQ_FFMTS(res)+op3] = EOS + } + + # Allocate space for the simple text field indices array. + call calloc (CQ_FINDICES(res), CQ_MAX_NFIELDS + 1, TY_INT) + + # Initilize the records descriptor. + CQ_RFD(res) = NULL + + call sfree (sp) + + return (res) +end + + +# Temporary definitions to get stuff working. Move into header file at some +# point ? + +define DIC_FNAMES "|type|hskip|tskip|recsize|triml|trimr|nheader|nfields|" +define DIC_TYPE 1 +define DIC_HSKIP 2 +define DIC_TSKIP 3 +define DIC_RECORD 4 +define DIC_TRIML 5 +define DIC_TRIMR 6 +define DIC_NHEADER 7 +define DIC_NFIELDS 8 + +# CQ_FRINIT -- Initialize a results descriptor from a file description. + +pointer procedure cq_frinit (cq, catfmt) + +pointer cq #I Initialize the results structure. +char catfmt[ARB] #I the catalog format desciption + +pointer res, sp, fname, funits, ffmt, fvalue +int i, ncount, sz1, sz2, sz3, op1, op2, op3, fd, foffset, fsize +int fscan(), nscan(), strdic(), strlen(), cq_dtype(), gstrcpy() +char ftype +int stropen() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (NULL) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (NULL) + + # Allocate the structure. + call calloc (res, CQ_LEN_RES, TY_STRUCT) + + # Format the catalog information, the address, query, and query + # parameters. + call strcpy (CQ_CATDB(cq), CQ_RCATDB(res), SZ_LINE) + call strcpy (CQ_CATNAME(cq), CQ_RCATNAME(res), SZ_LINE) + call strcpy ("", CQ_RADDRESS(res), SZ_LINE) + call strcpy ("", CQ_RQUERY(res), SZ_LINE) + CQ_RNQPARS(res) = 0 + call malloc (CQ_RQPNAMES(res), 1, TY_CHAR) + call malloc (CQ_RQPVALUES(res), 1, TY_CHAR) + call malloc (CQ_RQPUNITS(res), 1, TY_CHAR) + Memc[CQ_RQPNAMES(res)] = EOS + Memc[CQ_RQPVALUES(res)] = EOS + Memc[CQ_RQPUNITS(res)] = EOS + + # Set default file formats. + CQ_RTYPE(res) = CQ_STEXT + CQ_RHSKIP(res) = 0 + CQ_RTSKIP(res) = 0 + CQ_RECSIZE(res) = 0 + CQ_RTRIML(res) = 0 + CQ_RTRIMR(res) = 0 + CQ_NFIELDS(res) = 0 + + call smark(sp) + call salloc (fname, CQ_SZ_FNAME, TY_CHAR) + call salloc (funits, CQ_SZ_FUNITS, TY_CHAR) + call salloc (ffmt, CQ_SZ_FFMTS, TY_CHAR) + call salloc (fvalue, SZ_LINE, TY_CHAR) + + # Read in the defined file formats. + fd = stropen (catfmt, strlen (catfmt), READ_ONLY) + while (fscan (fd) != EOF) { + + # Get the field name. + call gargwrd (Memc[fname], CQ_SZ_FNAME) + if (nscan () < 1 || Memc[fname] == EOS) + next + i = strdic (Memc[fname], Memc[fname], CQ_SZ_FNAME, DIC_FNAMES) + + # Decode the field. + switch (i) { + + case DIC_TYPE: + call gargwrd (Memc[fname], CQ_SZ_FNAME) + if (nscan () < 2 || Memc[fname] == EOS) + CQ_RTYPE(res) = CQ_STEXT + else + CQ_RTYPE(res) = strdic (Memc[fname], Memc[fname], + CQ_SZ_FNAME, CQ_RTYPESTR) + + case DIC_HSKIP: + call gargi (CQ_RHSKIP(res)) + if (nscan() < 2) + CQ_RHSKIP(res) = 0 + + case DIC_TSKIP: + call gargi (CQ_RTSKIP(res)) + if (nscan() < 2) + CQ_RTSKIP(res) = 0 + + case DIC_RECORD: + call gargi (CQ_RECSIZE(res)) + if (nscan() < 2) + CQ_RECSIZE(res) = 0 + + case DIC_TRIML: + call gargi (CQ_RTRIML(res)) + if (nscan() < 2) + CQ_RTRIML(res) = 0 + + case DIC_TRIMR: + call gargi (CQ_RTRIMR(res)) + if (nscan() < 2) + CQ_RTRIMR(res) = 0 + + case DIC_NHEADER: + call gargi (CQ_NHEADER(res)) + if (nscan() < 2) + CQ_NHEADER(res) = 0 + + call calloc (CQ_HKNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_HKVALUES(res), SZ_LINE, TY_CHAR) + + ncount = 0 + if (CQ_NHEADER(res) > 0) { + + # Initialize the header name and value dictionaries. + sz1 = SZ_LINE; op1 = 2 + sz2 = SZ_LINE; op2 = 2 + call strcpy ("|", Memc[CQ_HKNAMES(res)], sz1) + call strcpy ("|", Memc[CQ_HKVALUES(res)], sz2) + + do i = 1, CQ_NHEADER(res) { + + # Get the keyword name and value. + if (fscan (fd) == EOF) + break + call gargwrd (Memc[fname], CQ_SZ_QPNAME) + call gargwrd (Memc[fvalue], SZ_LINE) + if (nscan() != 2) + break + + # Add the keyword name to the keyword dictionary. + if ((sz1 - op1 + 1) < (CQ_SZ_QPNAME + 1)) { + sz1 = sz1 + SZ_LINE + call realloc (CQ_HKNAMES(res), sz1, TY_CHAR) + } + op1 = op1 + gstrcpy (Memc[fname], Memc[CQ_HKNAMES(res)+ + op1-1], sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[CQ_HKNAMES(res)+op1-1], + sz1 - op1 + 1) + + # Add the keyword value to the keyword value dictionary. + if ((sz2 - op2 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz2 = sz2 + SZ_LINE + call realloc (CQ_HKVALUES(res), sz2, TY_CHAR) + } + op2 = op2 + gstrcpy (Memc[fvalue], + Memc[CQ_HKVALUES(res)+ op2-1], sz2 - op2 + 1) + op2 = op2 + gstrcpy ("|", Memc[CQ_HKVALUES(res)+op2-1], + sz2 - op2 + 1) + + ncount = ncount + 1 + } + } + + # Addjust the keyword dictionary sizes. + if (ncount != CQ_NHEADER(res)) { + CQ_NHEADER(res) = 0 + call realloc (CQ_HKNAMES(res), 1, TY_CHAR) + call realloc (CQ_HKVALUES(res), 1, TY_CHAR) + Memc[CQ_HKNAMES(res)] = EOS + Memc[CQ_HKVALUES(res)] = EOS + } else { + call realloc (CQ_HKNAMES(res), op1, TY_CHAR) + call realloc (CQ_HKVALUES(res), op2, TY_CHAR) + Memc[CQ_HKNAMES(res)+op1] = EOS + Memc[CQ_HKVALUES(res)+op2] = EOS + } + + case DIC_NFIELDS: + call gargi (CQ_NFIELDS(res)) + if (nscan() < 2) + CQ_NFIELDS(res) = 0 + + # Allocate space for the field descriptors. + call calloc (CQ_FNAMES(res), SZ_LINE, TY_CHAR) + call calloc (CQ_FOFFSETS(res), CQ_NFIELDS(res), TY_INT) + call calloc (CQ_FSIZES(res), CQ_NFIELDS(res), TY_INT) + call calloc (CQ_FTYPES(res), CQ_NFIELDS(res), TY_INT) + call calloc (CQ_FUNITS(res), SZ_LINE, TY_CHAR) + call calloc (CQ_FFMTS(res), SZ_LINE, TY_CHAR) + + ncount = 0 + if (CQ_NFIELDS(res) > 0) { + + sz1 = SZ_LINE; op1 = 2 + sz2 = SZ_LINE; op2 = 2 + sz3 = SZ_LINE; op3 = 2 + call strcpy ("|", Memc[CQ_FNAMES(res)], sz1) + call strcpy ("|", Memc[CQ_FUNITS(res)], sz2) + call strcpy ("|", Memc[CQ_FFMTS(res)], sz3) + + do i = 1, CQ_NFIELDS(res) { + + # Get the field description. + if (fscan (fd) == EOF) + break + call gargwrd (Memc[fname], CQ_SZ_FNAME) + call gargi (foffset) + call gargi (fsize) + call gargc (ftype) + call gargwrd (Memc[funits], CQ_SZ_FUNITS) + call gargwrd (Memc[ffmt], CQ_SZ_FFMTS) + if (nscan() != 6) + break + + # Add the field name to the field name dictionary. + if ((sz1 - op1 + 1) < (CQ_SZ_FNAME + 1)) { + sz1 = sz1 + SZ_LINE + call realloc (CQ_FNAMES(res), sz1, TY_CHAR) + } + op1 = op1 + gstrcpy (Memc[fname], Memc[CQ_FNAMES(res)+ + op1-1], sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[CQ_FNAMES(res)+op1-1], + sz1 - op1 + 1) + + Memi[CQ_FOFFSETS(res)+i-1] = foffset + Memi[CQ_FTYPES(res)+i-1] = cq_dtype (ftype) + Memi[CQ_FSIZES(res)+i-1] = fsize + + # Add the field units to the field units dictionary. + if ((sz2 - op2 + 1) < (CQ_SZ_FUNITS + 1)) { + sz2 = sz2 + SZ_LINE + call realloc (CQ_FUNITS(res), sz2, TY_CHAR) + } + op2 = op2 + gstrcpy (Memc[funits], + Memc[CQ_FUNITS(res)+ op2-1], sz2 - op2 + 1) + op2 = op2 + gstrcpy ("|", Memc[CQ_FUNITS(res)+op2-1], + sz2 - op2 + 1) + + # Add the field format to the field formats dictionary. + if ((sz3 - op3 + 1) < (CQ_SZ_FFMTS + 1)) { + sz3 = sz3 + SZ_LINE + call realloc (CQ_FFMTS(res), sz3, TY_CHAR) + } + op3 = op3 + gstrcpy (Memc[ffmt], + Memc[CQ_FFMTS(res)+ op3 -1], sz3 - op3 + 1) + op3 = op3 + gstrcpy ("|", Memc[CQ_FFMTS(res)+op3-1], + sz3 - op3 + 1) + + ncount = ncount + 1 + } + } + if (ncount != CQ_NFIELDS(res)) { + CQ_NFIELDS(res) = 0 + call realloc (CQ_FNAMES(res), 1, TY_CHAR) + Memc[CQ_FNAMES(res]) = EOS + call mfree (CQ_FOFFSETS(res), TY_INT) + CQ_FOFFSETS(res) = NULL + call mfree (CQ_FSIZES(res), TY_INT) + CQ_FSIZES(res) = NULL + call mfree (CQ_FTYPES(res), TY_INT) + CQ_FTYPES(res) = NULL + call realloc (CQ_FUNITS(res), 1, TY_CHAR) + Memc[CQ_FUNITS(res)] = EOS + call realloc (CQ_FFMTS(res), 1, TY_CHAR) + Memc[CQ_FFMTS(res)] = EOS + } else { + call realloc (CQ_FNAMES(res), op1, TY_CHAR) + call realloc (CQ_FUNITS(res), op2, TY_CHAR) + call realloc (CQ_FFMTS(res), op3, TY_CHAR) + Memc[CQ_FNAMES(res]+op1) = EOS + Memc[CQ_FUNITS(res)+op2] = EOS + Memc[CQ_FFMTS(res)+op3] = EOS + } + default: + ; + } + } + call close (fd) + call sfree (sp) + + # Allocate space for the field indices array. + call calloc (CQ_FINDICES(res), CQ_MAX_NFIELDS + 1, TY_INT) + + # Initilize the records descriptor. + CQ_RFD(res) = NULL + + return (res) +end + + +# CQ_RFREE -- Free the results structure. + +procedure cq_rfree (res) + +pointer res #U the results descriptor. + +begin + # Free the query parameter names, values, and units. + if (CQ_RQPNAMES(res) != NULL) + call mfree (CQ_RQPNAMES(res), TY_CHAR) + if (CQ_RQPVALUES(res) != NULL) + call mfree (CQ_RQPVALUES(res), TY_CHAR) + if (CQ_RQPUNITS(res) != NULL) + call mfree (CQ_RQPUNITS(res), TY_CHAR) + + # Free the header names and values. + if (CQ_HKNAMES(res) != NULL) + call mfree (CQ_HKNAMES(res), TY_CHAR) + if (CQ_HKVALUES(res) != NULL) + call mfree (CQ_HKVALUES(res), TY_CHAR) + + # Free the field offsets, sizes, and types. + if (CQ_FNAMES(res) != NULL) + call mfree (CQ_FNAMES(res), TY_CHAR) + if (CQ_FOFFSETS(res) != NULL) + call mfree (CQ_FOFFSETS(res), TY_INT) + if (CQ_FSIZES(res) != NULL) + call mfree (CQ_FSIZES(res), TY_INT) + if (CQ_FTYPES(res) != NULL) + call mfree (CQ_FTYPES(res), TY_INT) + if (CQ_FUNITS(res) != NULL) + call mfree (CQ_FUNITS(res), TY_CHAR) + if (CQ_FFMTS(res) != NULL) + call mfree (CQ_FFMTS(res), TY_CHAR) + + # Free the record description. + if (CQ_FINDICES(res) != NULL) + call mfree (CQ_FINDICES(res), TY_INT) + + # Free the record buffer. + if (CQ_RINDEX(res) != NULL) + call mfree (CQ_RINDEX(res), TY_LONG) + if (CQ_RFD(res) != NULL) + call close (CQ_RFD(res)) + + if (res != NULL) + call mfree (res, TY_STRUCT) +end diff --git a/pkg/xtools/catquery/cqrinfo.x b/pkg/xtools/catquery/cqrinfo.x new file mode 100644 index 00000000..f61dc949 --- /dev/null +++ b/pkg/xtools/catquery/cqrinfo.x @@ -0,0 +1,390 @@ +include "cqdef.h" +include "cq.h" + + +# CQ_HINFO -- Get the header keyword value by keyword name. + +int procedure cq_hinfo (res, hkname, hkvalue, sz_hkvalue) + +pointer res #I the results descriptor +char hkname[ARB] #I the header keyword name +char hkvalue[ARB] #O the header keyword value +int sz_hkvalue #I the maximum size of the keyword value + +pointer sp, kname +int kwno +int strdic(), cq_wrdstr() + +begin + # Return if there are no fields. + if (CQ_NHEADER(res) <= 0) + return (0) + + call smark (sp) + call salloc (kname, CQ_SZ_FNAME, TY_CHAR) + + # Find the requested field. + kwno = strdic (hkname, Memc[kname], CQ_SZ_FNAME, Memc[CQ_HKNAMES(res)]) + if (kwno <= 0) { + call sfree (sp) + return (0) + } + + # Retrieve the keyword value. + if (cq_wrdstr (kwno, hkvalue, sz_hkvalue, Memc[CQ_HKVALUES(res)]) <= 0) + hkvalue[1] = EOS + + call sfree (sp) + + return (kwno) +end + + +# CQ_HINFON -- Get the header keyword name and value using the keyword number. + +int procedure cq_hinfon (res, kwno, hkname, sz_hkname, hkvalue, sz_hkvalue) + +pointer res #I the results descriptor +int kwno #I the keyword number +char hkname[ARB] #O the header keyword name +int sz_hkname #I the maximum size of the keyword name +char hkvalue[ARB] #O the header keyword value +int sz_hkvalue #I the maximum size of the keyword value + +int cq_wrdstr() + +begin + # Return if there are no keywords. + if (CQ_NHEADER(res) <= 0) + return (0) + + # Return if the keyword is out of bounds. + if (kwno < 1 || kwno > CQ_NHEADER(res)) + return (0) + + # Retrieve the keyword value. + if (cq_wrdstr (kwno, hkname, sz_hkname, Memc[CQ_HKNAMES(res)]) <= 0) + hkname[1] = EOS + + # Retrieve the keyword value. + if (cq_wrdstr (kwno, hkvalue, sz_hkvalue, Memc[CQ_HKVALUES(res)]) <= 0) + hkvalue[1] = EOS + + return (kwno) +end + + +# CQ_FINFO -- Get the field description by field name. + +int procedure cq_finfo (res, field, foffset, fsize, ftype, units, sz_units, + fmts, sz_fmts) + +pointer res #I the results descriptor +char field[ARB] #I the field name +int foffset #O the output field offset +int fsize #O the output field size +int ftype #O the output field datatype +char units[ARB] #O the outpit field units string +int sz_units #I the maximum size of the units string +char fmts[ARB] #O the outpit field formats string +int sz_fmts #I the maximum size of the formats string + +pointer sp, fname +int fieldno +int strdic(), cq_wrdstr() + +begin + # Return if there are no fields. + if (CQ_NFIELDS(res) <= 0) + return (0) + + call smark (sp) + call salloc (fname, CQ_SZ_FNAME, TY_CHAR) + + # Find the requested field. + fieldno = strdic (field, Memc[fname], CQ_SZ_FNAME, Memc[CQ_FNAMES(res)]) + if (fieldno <= 0) { + call sfree (sp) + return (0) + } + + # Get the field offset, size, and type. + foffset = Memi[CQ_FOFFSETS(res)+fieldno-1] + fsize = Memi[CQ_FSIZES(res)+fieldno-1] + ftype = Memi[CQ_FTYPES(res)+fieldno-1] + + # Get the field units and format. + if (cq_wrdstr (fieldno, units, sz_units, Memc[CQ_FUNITS(res)]) <= 0) + units[1] = EOS + if (cq_wrdstr (fieldno, fmts, sz_fmts, Memc[CQ_FFMTS(res)]) <= 0) + fmts[1] = EOS + + call sfree (sp) + + return (fieldno) +end + + +# CQ_FNUMBER -- Get the field number given the field name. + +int procedure cq_fnumber (res, field) + +pointer res #I the results descriptor +char field[ARB] #I the field name + +pointer sp, fname +int fieldno +int strdic() + +begin + # Return if there are no fields. + if (CQ_NFIELDS(res) <= 0) + return (0) + + call smark (sp) + call salloc (fname, CQ_SZ_FNAME, TY_CHAR) + + # Find the requested field. + fieldno = strdic (field, Memc[fname], CQ_SZ_FNAME, Memc[CQ_FNAMES(res)]) + + call sfree (sp) + return (fieldno) +end + + +# CQ_FOFFSET -- Get the field offset given the field name. + +int procedure cq_foffset (res, field) + +pointer res #I the results descriptor +char field[ARB] #I the field name + +pointer sp, fname +int fieldno +int strdic() + +begin + # Return if there are no fields. + if (CQ_NFIELDS(res) <= 0) + return (0) + + call smark (sp) + call salloc (fname, CQ_SZ_FNAME, TY_CHAR) + + # Find the requested field. + fieldno = strdic (field, Memc[fname], CQ_SZ_FNAME, Memc[CQ_FNAMES(res)]) + + call sfree (sp) + + if (fieldno <= 0) + return (0) + else + return (Memi[CQ_FOFFSETS(res)+fieldno-1]) +end + + +# CQ_FSIZE -- Get the field offset given the field name. + +int procedure cq_fsize (res, field) + +pointer res #I the results descriptor +char field[ARB] #I the field name + +pointer sp, fname +int fieldno +int strdic() + +begin + # Return if there are no fields. + if (CQ_NFIELDS(res) <= 0) + return (0) + + call smark (sp) + call salloc (fname, CQ_SZ_FNAME, TY_CHAR) + + # Find the requested field. + fieldno = strdic (field, Memc[fname], CQ_SZ_FNAME, Memc[CQ_FNAMES(res)]) + + call sfree (sp) + + if (fieldno <= 0) + return (0) + else + return (Memi[CQ_FSIZES(res)+fieldno-1]) +end + + +# CQ_FTYPE -- Get the field type given the field name. + +int procedure cq_ftype (res, field) + +pointer res #I the results descriptor +char field[ARB] #I the field name + +pointer sp, fname +int fieldno +int strdic() + +begin + # Return if there are no fields. + if (CQ_NFIELDS(res) <= 0) + return (0) + + call smark (sp) + call salloc (fname, CQ_SZ_FNAME, TY_CHAR) + + # Find the requested field. + fieldno = strdic (field, Memc[fname], CQ_SZ_FNAME, Memc[CQ_FNAMES(res)]) + + call sfree (sp) + + if (fieldno <= 0) + return (0) + else + return (Memi[CQ_FTYPES(res)+fieldno-1]) +end + + +# CQ_FUNITS -- Get the field units given the field name. + +procedure cq_funits (res, field, units, sz_units) + +pointer res #I the results descriptor +char field[ARB] #I the field name +char units[ARB] #O the output units string +int sz_units #I the maximum size of the units string + +pointer sp, fname +int fieldno +int strdic(), cq_wrdstr() + +begin + # Return if there are no fields. + if (CQ_NFIELDS(res) <= 0) { + units[1] = EOS + return + } + + call smark (sp) + call salloc (fname, CQ_SZ_FNAME, TY_CHAR) + + # Find the requested field. + fieldno = strdic (field, Memc[fname], CQ_SZ_FNAME, Memc[CQ_FNAMES(res)]) + + # Get the units string. + if (fieldno > 0) { + if (cq_wrdstr (fieldno, units, sz_units, Memc[CQ_FUNITS(res)]) <= 0) + units[1] = EOS + } else + units[1] = EOS + + call sfree (sp) +end + + +# CQ_FFMTS -- Get the field format given the field name. + +procedure cq_ffmts (res, field, format, sz_format) + +pointer res #I the results descriptor +char field[ARB] #I the field name +char format[ARB] #O the output format string +int sz_format #I the maximum size of the format string + +pointer sp, fname +int fieldno +int strdic(), cq_wrdstr() + +begin + # Return if there are no fields. + if (CQ_NFIELDS(res) <= 0) { + format[1] = EOS + return + } + + call smark (sp) + call salloc (fname, CQ_SZ_FNAME, TY_CHAR) + + # Find the requested field. + fieldno = strdic (field, Memc[fname], CQ_SZ_FNAME, Memc[CQ_FNAMES(res)]) + + # Get the units string. + if (fieldno > 0) { + if (cq_wrdstr (fieldno, format, sz_format, + Memc[CQ_FFMTS(res)]) <= 0) + format[1] = EOS + } else + format[1] = EOS + + call sfree (sp) +end + + +# CQ_FINFON -- Get the field description by field number. + +int procedure cq_finfon (res, fieldno, fname, sz_fname, foffset, fsize, ftype, + units, sz_units, fmts, sz_fmts) + +pointer res #I the results descriptor +int fieldno #I the input field number +char fname[ARB] #O the field name +int sz_fname #I the maximum field name size +int foffset #O the output field offset +int fsize #O the output field size +int ftype #O the output field datatype +char units[ARB] #O the outpit field units string +int sz_units #I the maximum size of the units string +char fmts[ARB] #O the outpit field formats string +int sz_fmts #I the maximum size of the formats string + +int cq_wrdstr() + +begin + # Return if there are no fields. + if (CQ_NFIELDS(res) <= 0) + return (0) + if (fieldno <= 0 || fieldno > CQ_NFIELDS(res)) + return (0) + + # Get the field name. + if (cq_wrdstr (fieldno, fname, sz_fname, Memc[CQ_FNAMES(res)]) <= 0) + return (0) + + # Set the field offset, size, and type. + foffset = Memi[CQ_FOFFSETS(res)+fieldno-1] + fsize = Memi[CQ_FSIZES(res)+fieldno-1] + ftype = Memi[CQ_FTYPES(res)+fieldno-1] + + if (cq_wrdstr (fieldno, units, sz_units, Memc[CQ_FUNITS(res)]) <= 0) + units[1] = EOS + if (cq_wrdstr (fieldno, fmts, sz_fmts, Memc[CQ_FFMTS(res)]) <= 0) + fmts[1] = EOS + + return (fieldno) +end + + +# CQ_FNAME -- Get the field name given the field number. + +int procedure cq_fname (res, fieldno, fname, sz_fname) + +pointer res #I the results descriptor +int fieldno #I the input field number +char fname[ARB] #O the field name +int sz_fname #I the maximum field name size + +int cq_wrdstr() + +begin + # Return if there are no fields. + if (CQ_NFIELDS(res) <= 0) + return (0) + if (fieldno <= 0 || fieldno > CQ_NFIELDS(res)) + return (0) + + # Get the field name. + if (cq_wrdstr (fieldno, fname, sz_fname, Memc[CQ_FNAMES(res)]) <= 0) + return (0) + + return (fieldno) +end diff --git a/pkg/xtools/catquery/cqrstat.x b/pkg/xtools/catquery/cqrstat.x new file mode 100644 index 00000000..60319e77 --- /dev/null +++ b/pkg/xtools/catquery/cqrstat.x @@ -0,0 +1,171 @@ +include "cqdef.h" +include "cq.h" + + +# CQ_RSTATI -- Get an integer results parameter. + +int procedure cq_rstati (res, param) + +pointer res #I pointer to the results descriptor +int param #I the integer parameter to be retrieved + +begin + switch (param) { + case CQRNQPARS: + return (CQ_RNQPARS(res)) + case CQRTYPE: + return (CQ_RTYPE(res)) + case CQRNRECS: + return (CQ_RNRECS(res)) + case CQRECSIZE: + return (CQ_RECSIZE(res)) + case CQRHSKIP: + return (CQ_RHSKIP(res)) + case CQRTSKIP: + return (CQ_RTSKIP(res)) + case CQRTRIML: + return (CQ_RTRIML(res)) + case CQRTRIMR: + return (CQ_RTRIMR(res)) + case CQNHEADER: + return (CQ_NHEADER(res)) + case CQNFIELDS: + return (CQ_NFIELDS(res)) + case CQRECPTR: + return (CQ_RECPTR(res)) + default: + call error (0, "Error fetching integer results parameter") + } +end + + +# CQ_RSTATR -- Get a real results parameter. + +real procedure cq_rstatr (res, param) + +pointer res #I pointer to the results descriptor +int param #I the real parameter to be retrieved + +begin + switch (param) { + default: + call error (0, "Error fetching real results parameter") + } +end + + +# CQ_RSTATD -- Get a double precision results parameter. + +double procedure cq_rstatd (res, param) + +pointer res #I pointer to the results descriptor +int param #I the double parameter to be retrieved + +begin + switch (param) { + default: + call error (0, "Error fetching double results parameter") + } +end + + +# CQ_RSTATS -- Get a string results parameter. + +procedure cq_rstats (res, param, str, maxch) + +pointer res #I pointer to the results descriptor +int param #I the string parameter to be retrieved +char str[ARB] #O the output string parameter +int maxch #I the maximum size of the string parameter + +begin + switch (param) { + case CQRCATDB: + call strcpy (CQ_RCATDB(res), str, maxch) + case CQRCATNAME: + call strcpy (CQ_RCATNAME(res), str, maxch) + case CQRADDRESS: + call strcpy (CQ_RADDRESS(res), str, maxch) + case CQRQUERY: + call strcpy (CQ_RQUERY(res), str, maxch) + case CQRQPNAMES: + call strcpy (Memc[CQ_RQPNAMES(res)], str, maxch) + case CQRQPVALUES: + call strcpy (Memc[CQ_RQPVALUES(res)], str, maxch) + case CQRQPUNITS: + call strcpy (Memc[CQ_RQPUNITS(res)], str, maxch) + default: + call error (0, "Error fetching string results parameter") + } +end + + +# CQ_RSTATT -- Get a text list results parameter. A text list is a +# string with items separated from each other by newlines. + +int procedure cq_rstatt (res, param, str, maxch) + +pointer res #I pointer to the results descriptor +int param #I the list parameter to be retrieved +char str[ARB] #O the output string parameter +int maxch #I the maximum size of the string parameter + +pointer sp, tstr +int i, fd +int stropen(), cq_wrdstr() + +begin + switch (param) { + + case CQRQPNAMES: + call smark (sp) + call salloc (tstr, CQ_SZ_QPNAME, TY_CHAR) + fd = stropen (str, maxch, NEW_FILE) + str[1] = EOS + do i = 1, CQ_RNQPARS(res) { + if (cq_wrdstr (i, Memc[tstr], CQ_SZ_QPNAME, + Memc[CQ_RQPNAMES(res)]) > 0) { + call fprintf (fd, "%s\n") + call pargstr (Memc[tstr]) + } + } + call close (fd) + call sfree (sp) + return (CQ_RNQPARS(res)) + + case CQRQPVALUES: + call smark (sp) + call salloc (tstr, CQ_SZ_QPVALUE, TY_CHAR) + fd = stropen (str, maxch, NEW_FILE) + str[1] = EOS + do i = 1, CQ_RNQPARS(res) { + if (cq_wrdstr (i, Memc[tstr], CQ_SZ_QPVALUE, + Memc[CQ_RQPVALUES(res)]) > 0) { + call fprintf (fd, "%s\n") + call pargstr (Memc[tstr]) + } + } + call close (fd) + call sfree (sp) + return (CQ_RNQPARS(res)) + + case CQRQPUNITS: + call smark (sp) + call salloc (tstr, CQ_SZ_QPUNITS, TY_CHAR) + fd = stropen (str, maxch, NEW_FILE) + str[1] = EOS + do i = 1, CQ_RNQPARS(res) { + if (cq_wrdstr (i, Memc[tstr], CQ_SZ_QPUNITS, + Memc[CQ_RQPUNITS(res)]) > 0) { + call fprintf (fd, "%s\n") + call pargstr (Memc[tstr]) + } + } + call close (fd) + call sfree (sp) + return (CQ_RNQPARS(res)) + + default: + call error (0, "Error fetching list results parameter") + } +end diff --git a/pkg/xtools/catquery/cqsetcat.x b/pkg/xtools/catquery/cqsetcat.x new file mode 100644 index 00000000..f64ae4c3 --- /dev/null +++ b/pkg/xtools/catquery/cqsetcat.x @@ -0,0 +1,293 @@ +include "cqdef.h" +include "cq.h" + + +# CQ_SETCAT -- Set the current catalog by name. + +int procedure cq_setcat (cq, name) + +pointer cq #I the catalog descriptor +char name[ARB] #I the catalog name + +int i, catno +int cq_ccrquery() +bool streq() + +begin + catno = 0 + do i = 1, CQ_NRECS(cq) { + if (streq (name, CQ_NAME(cq, i))) + catno = i + } + if (catno == 0) + return (0) + + # Free the previous current catalog descriptor if any. + call cq_ccfree (cq) + + # Allocate the new descriptor. + call cq_ccinit (cq, catno) + + # Get the new catalog parameters. + if (cq_ccrquery (cq) == ERR) { + call cq_ccfree (cq) + return (0) + } + + return (catno) +end + + +# CQ_SETCATN -- Set the current catalog by number. + +int procedure cq_setcatn (cq, catno) + +pointer cq #I the catalog descriptor +int catno #I the catalog number + +int cq_ccrquery() + +begin + if (catno < 1 || catno > CQ_NRECS(cq)) + return (0) + + # Free the previous current catalog descriptor if any. + call cq_ccfree (cq) + + # Allocate the new descriptor. + call cq_ccinit (cq, catno) + + # Get the new catalog parameters. + if (cq_ccrquery (cq) == ERR) { + call cq_ccfree (cq) + return (0) + } + + return (catno) +end + + +# CQ_CCINIT -- Initialize the current catalog descriptor. + +procedure cq_ccinit (cq, catno) + +pointer cq #I the catalog database descriptor +int catno #I the current catalog number + +pointer cc + +begin + if (catno < 1 || catno > CQ_NRECS(cq)) + return + CQ_CATNO(cq) = catno + call strcpy (CQ_NAME(cq, catno), CQ_CATNAME(cq), SZ_FNAME) + + call calloc (CQ_CAT(cq), CQ_LEN_CC, TY_STRUCT) + cc = CQ_CAT(cq) + + CQ_NQPARS(cc) = 0 + CQ_HFMT(cc) = CQ_HNONE + + call calloc (CQ_PQPNAMES(cc), SZ_LINE, TY_CHAR) + call calloc (CQ_PQPDVALUES(cc), SZ_LINE, TY_CHAR) + call calloc (CQ_PQPVALUES(cc), SZ_LINE, TY_CHAR) + call calloc (CQ_PQPUNITS(cc), SZ_LINE, TY_CHAR) + call calloc (CQ_PQPFMTS(cc), SZ_LINE, TY_CHAR) + + Memc[CQ_PQPNAMES(cc)] = EOS + Memc[CQ_PQPDVALUES(cc)] = EOS + Memc[CQ_PQPVALUES(cc)] = EOS + Memc[CQ_PQPUNITS(cc)] = EOS + Memc[CQ_PQPFMTS(cc)] = EOS + + CQ_ADDRESS(cc) = EOS + CQ_QUERY(cc) = EOS + +end + + +# CQ_CCRQUERY -- Read in the query related parameters from the catalog +# database. May need to encode the field names at some point. + +int procedure cq_ccrquery (cq) + +pointer cq #I the catalog database descriptor + +pointer cc, sp, str +int i, catno, nqpars, npars, sz1, sz2, sz3, sz4, sz5 +int op1, op2, op3, op4, op5 +int cq_dgeti(), cq_dscan(), nscan(), gstrcpy(), strdic() +errchk cq_dgwrd(), cq_dgeti(), cq_dscan() + +begin + # If the current catalog is not defined then return. + if (CQ_CAT(cq) == NULL) + return (ERR) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (ERR) + cc = CQ_CAT(cq) + catno = CQ_CATNO(cq) + + call smark (sp) + call salloc (str, 4 * (SZ_LINE + 1), TY_CHAR) + + iferr { + + # Get the catalog address and query string. + call cq_dgwrd (cq, catno, "address", CQ_ADDRESS(cc), SZ_LINE) + call cq_dgstr (cq, catno, "query", CQ_QUERY(cc), SZ_LINE) + + # Get the protocol. + call cq_dgwrd (cq, catno, "protocol", Memc[str], SZ_LINE) + CQ_HFMT(cc) = strdic (Memc[str], Memc[str], SZ_LINE, + CQ_HFMTSTR) + if (CQ_HFMT(cc) <= 0) + CQ_HFMT(cc) = CQ_HNONE + + # Determine the number of query parameters and position the + # file to the correct place. + nqpars = cq_dgeti (cq, catno, "nquery") + + } then { + + # Reinitialize and return. + CQ_ADDRESS(cc) = EOS + CQ_QUERY(cc) = EOS + call sfree (sp) + return (ERR) + } + + + # Open the query parameter string dictionaries. + sz1 = SZ_LINE; op1 = 2 + sz2 = SZ_LINE; op2 = 2 + sz3 = SZ_LINE; op3 = 2 + sz4 = SZ_LINE; op4 = 2 + sz5 = SZ_LINE; op5 = 2 + call strcpy ("|", Memc[CQ_PQPNAMES(cc)], sz1) + call strcpy ("|", Memc[CQ_PQPDVALUES(cc)], sz2) + call strcpy ("|", Memc[CQ_PQPVALUES(cc)], sz3) + call strcpy ("|", Memc[CQ_PQPUNITS(cc)], sz4) + call strcpy ("|", Memc[CQ_PQPFMTS(cc)], sz5) + + # Scan the query parameter list. + npars = 0 + for (i = 1; i <= nqpars; i = i + 1) { + if (cq_dscan (cq) == EOF) + break + + # Get the query parameter fields. + call gargwrd (Memc[str], SZ_LINE) + call gargwrd (Memc[str+SZ_LINE+1], SZ_LINE) + call gargwrd (Memc[str+2*(SZ_LINE+1)], SZ_LINE) + call gargwrd (Memc[str+3*(SZ_LINE+1)], SZ_LINE) + if (nscan() != 4) + break + + # Get the query parameter name. + if ((sz1 - op1 + 1) < (CQ_SZ_QPNAME + 1)) { + sz1 = sz1 + SZ_LINE + call realloc (CQ_PQPNAMES(cc), sz1, TY_CHAR) + } + op1 = op1 + gstrcpy (Memc[str], Memc[CQ_PQPNAMES(cc)+op1-1], + sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[CQ_PQPNAMES(cc)+op1-1], + sz1 - op1 + 1) + + # Get the default query parameter value and initialize the + # user query parameter string. + if ((sz2 - op2 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz2 = sz2 + SZ_LINE + sz3 = sz3 + SZ_LINE + call realloc (CQ_PQPDVALUES(cc), sz2, TY_CHAR) + call realloc (CQ_PQPVALUES(cc), sz3, TY_CHAR) + } + op2 = op2 + gstrcpy (Memc[str+SZ_LINE+1], + Memc[CQ_PQPDVALUES(cc)+op2-1], sz2 - op2 + 1) + op2 = op2 + gstrcpy ("|", Memc[CQ_PQPDVALUES(cc)+op2-1], + sz2 - op2 + 1) + op3 = op3 + gstrcpy (Memc[str+SZ_LINE+1], + Memc[CQ_PQPVALUES(cc)+op3-1], sz3 - op3 + 1) + op3 = op3 + gstrcpy ("|", Memc[CQ_PQPVALUES(cc)+op3-1], + sz3 - op3 + 1) + + # Get the query parameter units. + if ((sz4 - op4 + 1) < (CQ_SZ_QPUNITS + 1)) { + sz4 = sz4 + SZ_LINE + call realloc (CQ_PQPUNITS(cc), sz4, TY_CHAR) + } + op4 = op4 + gstrcpy (Memc[str+2*(SZ_LINE+1)], + Memc[CQ_PQPUNITS(cc)+op4-1], sz4 - op4 + 1) + op4 = op4 + gstrcpy ("|", Memc[CQ_PQPUNITS(cc)+op4-1], + sz4 - op4 + 1) + + # Get the query parameter formats. + if ((sz5 - op5 + 1) < (CQ_SZ_QPFMTS + 1)) { + sz5 = sz5 + SZ_LINE + call realloc (CQ_PQPFMTS(cc), sz5, TY_CHAR) + } + op5 = op5 + gstrcpy (Memc[str+3*(SZ_LINE+1)], + Memc[CQ_PQPFMTS(cc)+op5-1], sz5 - op5 + 1) + op5 = op5 + gstrcpy ("|", Memc[CQ_PQPFMTS(cc)+op5-1], + sz5 - op5 + 1) + + npars = npars + 1 + } + + # Return the appropriate status. + call sfree (sp) + if (npars != nqpars) { + CQ_NQPARS(cc) = 0 + call realloc (CQ_PQPNAMES(cc), SZ_LINE, TY_CHAR) + call realloc (CQ_PQPDVALUES(cc), SZ_LINE, TY_CHAR) + call realloc (CQ_PQPVALUES(cc), SZ_LINE, TY_CHAR) + call realloc (CQ_PQPUNITS(cc), SZ_LINE, TY_CHAR) + call realloc (CQ_PQPFMTS(cc), SZ_LINE, TY_CHAR) + Memc[CQ_PQPNAMES(cc)] = EOS + Memc[CQ_PQPDVALUES(cc)] = EOS + Memc[CQ_PQPVALUES(cc)] = EOS + Memc[CQ_PQPUNITS(cc)] = EOS + Memc[CQ_PQPFMTS(cc)] = EOS + CQ_ADDRESS(cc) = EOS + CQ_QUERY(cc) = EOS + return (ERR) + } else { + CQ_NQPARS(cc) = npars + call realloc (CQ_PQPNAMES(cc), op1, TY_CHAR) + call realloc (CQ_PQPDVALUES(cc), op2, TY_CHAR) + call realloc (CQ_PQPVALUES(cc), op3, TY_CHAR) + call realloc (CQ_PQPUNITS(cc), op4, TY_CHAR) + call realloc (CQ_PQPFMTS(cc), op5, TY_CHAR) + Memc[CQ_PQPNAMES(cc)+op1] = EOS + Memc[CQ_PQPDVALUES(cc)+op2] = EOS + Memc[CQ_PQPVALUES(cc)+op3] = EOS + Memc[CQ_PQPUNITS(cc)+op4] = EOS + Memc[CQ_PQPFMTS(cc)+op5] = EOS + return (OK) + } +end + + +# CQ_CCFREE - Free the current catalog descriptor + +procedure cq_ccfree (cq) + +pointer cq #I the catalog database descriptor + +pointer cc + +begin + CQ_CATNAME(cq) = EOS + CQ_CATNO(cq) = 0 + + if (CQ_CAT(cq) != NULL) { + cc = CQ_CAT(cq) + call mfree (CQ_PQPNAMES(cc), TY_CHAR) + call mfree (CQ_PQPDVALUES(cc), TY_CHAR) + call mfree (CQ_PQPVALUES(cc), TY_CHAR) + call mfree (CQ_PQPUNITS(cc), TY_CHAR) + call mfree (CQ_PQPFMTS(cc), TY_CHAR) + call mfree (CQ_CAT(cq), TY_STRUCT) + } + CQ_CAT(cq) = NULL +end diff --git a/pkg/xtools/catquery/cqsqpars.x b/pkg/xtools/catquery/cqsqpars.x new file mode 100644 index 00000000..e2ab9c3c --- /dev/null +++ b/pkg/xtools/catquery/cqsqpars.x @@ -0,0 +1,135 @@ +include "cqdef.h" +include "cq.h" + + +# CQ_SQPAR -- Set the value of a query parameter by name. + +int procedure cq_sqpar (cq, name, valuestr) + +pointer cq #I the catalog descriptor +char name[ARB] #I the input query parameter name +char valuestr[ARB] #I the parameter value string + +pointer cc, sp, pname, tmpdic, pvalue +int i, parno, sz1, op1 +int strdic(), strlen(), cq_wrdstr(), gstrcpy() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (0) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (0) + cc = CQ_CAT(cq) + + + # Allocate temporary space. + call smark (sp) + call salloc (pname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (pvalue, CQ_SZ_QPVALUE, TY_CHAR) + + # Locate the parameter. + parno = strdic (name, Memc[pname], CQ_SZ_QPNAME, Memc[CQ_PQPNAMES(cc)]) + if (parno <= 0) { + call sfree (sp) + return (0) + } + + # Initalize the temporary string. + sz1 = strlen (Memc[CQ_PQPVALUES(cc)]) + CQ_SZ_QPVALUE + call malloc (tmpdic, sz1, TY_CHAR) + call strcpy ("|", Memc[tmpdic], sz1) + op1 = 2 + + + # Reformat the values string. + do i = 1, CQ_NQPARS(cc) { + if ((sz1 - op1 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz1 = sz1 + SZ_LINE + call realloc (tmpdic, sz1, TY_CHAR) + } + if (i == parno) { + op1 = op1 + gstrcpy (valuestr, Memc[tmpdic+op1-1], + sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[tmpdic+op1-1], sz1 - op1 + 1) + } else if (cq_wrdstr (i, Memc[pvalue], CQ_SZ_QPNAME, + Memc[CQ_PQPVALUES(cc)]) > 0) { + op1 = op1 + gstrcpy (Memc[pvalue], Memc[tmpdic+op1-1], + sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[tmpdic+op1-1], sz1 - op1 + 1) + } + } + + # Update the values string. Leave as temp length for now. + call realloc (CQ_PQPVALUES(cc), op1 - 1, TY_CHAR) + call strcpy (Memc[tmpdic], Memc[CQ_PQPVALUES(cc)], op1 - 1) + + call mfree (tmpdic, TY_CHAR) + call sfree (sp) + + return (parno) +end + + +# CQ_SQPARN -- Set the value of a query parameter by number. + +int procedure cq_sqparn (cq, parno, valuestr) + +pointer cq #I the catalog descriptor +int parno #I the query parameter number +char valuestr[ARB] #I the parameter value string + +pointer cc, sp, pname, tmpdic, pvalue +int i, sz1, op1 +int strlen(), cq_wrdstr(), gstrcpy() + +begin + # Check that the current catalog is defined. + if (CQ_CAT(cq) == NULL) + return (0) + if (CQ_CATNO(cq) < 1 || CQ_CATNO(cq) > CQ_NRECS(cq)) + return (0) + cc = CQ_CAT(cq) + + if (parno < 1 || parno > CQ_NQPARS(cc)) + return (0) + + # Get some working space. + call smark (sp) + call salloc (pname, CQ_SZ_QPNAME, TY_CHAR) + call salloc (pvalue, CQ_SZ_QPVALUE, TY_CHAR) + + # Initialize the new dictionary. + sz1 = strlen (Memc[CQ_PQPVALUES(cc)]) + CQ_SZ_QPVALUE + call calloc (tmpdic, sz1, TY_CHAR) + call strcpy ("|", Memc[tmpdic], sz1) + op1 = 2 + + # Reformat the values string. + do i = 1, CQ_NQPARS(cc) { + if ((sz1 - op1 + 1) < (CQ_SZ_QPVALUE + 1)) { + sz1 = sz1 + SZ_LINE + call realloc (tmpdic, sz1, TY_CHAR) + } + if (i == parno) { + op1 = op1 + gstrcpy (valuestr, Memc[tmpdic+op1-1], + sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[tmpdic+op1-1], sz1 - op1 + 1) + } else if (cq_wrdstr (i, Memc[pvalue], CQ_SZ_QPNAME, + Memc[CQ_PQPVALUES(cc)]) > 0) { + op1 = op1 + gstrcpy (Memc[pvalue], Memc[tmpdic+op1-1], + sz1 - op1 + 1) + op1 = op1 + gstrcpy ("|", Memc[tmpdic+op1-1], sz1 - op1 + 1) + } + } + + # Update the values string. + call realloc (CQ_PQPVALUES(cc), op1, TY_CHAR) + call strcpy (Memc[tmpdic], Memc[CQ_PQPVALUES(cc)], op1 - 1) + + # Free memory. + call mfree (tmpdic, TY_CHAR) + call sfree (sp) + + return (parno) +end diff --git a/pkg/xtools/catquery/cqstat.x b/pkg/xtools/catquery/cqstat.x new file mode 100644 index 00000000..152022a9 --- /dev/null +++ b/pkg/xtools/catquery/cqstat.x @@ -0,0 +1,74 @@ +include "cqdef.h" +include "cq.h" + + +# CQ_STATI -- Get an integer catalog database parameter. + +int procedure cq_stati (cq, param) + +pointer cq #I pointer to the catalog query structure. +int param #I the integer parameter to be retrieved + +begin + switch (param) { + case CQNRECS: + return (CQ_NRECS(cq)) + case CQSZRECLIST: + return (CQ_NAMEI(cq, CQ_NRECS(cq) + 1)) + case CQCATNO: + return (CQ_CATNO(cq)) + default: + call error (0, "Error fetching integer catalog database parameter") + } +end + + + +# CQ_STATS -- Get a string catalog database parameter. + +procedure cq_stats (cq, param, str, maxch) + +pointer cq #I pointer to the catalog query structure. +int param #I the string parameter to be retrieved +char str[ARB] #O the output string parameter +int maxch #I the maximum size of the string parameter + +begin + switch (param) { + case CQCATDB: + call strcpy (CQ_CATDB(cq), str, maxch) + case CQCATNAME: + call strcpy (CQ_CATNAME(cq), str, maxch) + default: + call error (0, "Error fetching string catalog database parameter") + } +end + + +# CQ_STATT -- Get a text list catalog database parameter. A text list is a +# string with items separated from each other by newlines. + +int procedure cq_statt (cq, param, str, maxch) + +pointer cq #I pointer to the catalog query structure. +int param #I the list parameter to be retrieved +char str[ARB] #O the output string parameter +int maxch #I the maximum size of the string parameter + +int i, fd +int stropen() + +begin + switch (param) { + case CQRECLIST: + fd = stropen (str, maxch, NEW_FILE) + do i = 1, CQ_NRECS(cq) { + call fprintf (fd, "%s\n") + call pargstr (CQ_NAME(cq, i)) + } + call strclose (fd) + return (CQ_NRECS(cq)) + default: + call error (0, "Error fetching list catalog database parameter") + } +end diff --git a/pkg/xtools/catquery/cqwrdstr.x b/pkg/xtools/catquery/cqwrdstr.x new file mode 100644 index 00000000..bfdf1088 --- /dev/null +++ b/pkg/xtools/catquery/cqwrdstr.x @@ -0,0 +1,56 @@ + +# CQ_WRDSTR -- Search a dictionary string for a given string index number. +# This is the opposite function of strdic(), that returns the index for +# given string. The entries in the dictionary string are separated by +# a delimiter character which is the first character of the dictionary +# string. The index of the string found is returned as the function value. +# Otherwise, if there is no string for that index, a zero is returned. + +int procedure cq_wrdstr (index, outstr, maxch, dict) + +int index # String index +char outstr[ARB] # Output string as found in dictionary +int maxch # Maximum length of output string +char dict[ARB] # Dictionary string + +int i, len, start, count + +int strlen() + +begin + # Clear output string + outstr[1] = EOS + + # Return if the dictionary is not long enough + if (dict[1] == EOS) + return (0) + + # Return if the index is less than or equal to zero. + if (index <= 0) + return (0) + + # Initialize counters + count = 1 + len = strlen (dict) + + # Search the dictionary string. This loop only terminates + # successfully if the index is found. Otherwise the procedure + # returns with and error condition. + for (start = 2; count < index; start = start + 1) { + if (dict[start] == dict[1]) + count = count + 1 + if (start == len) + return (0) + } + + # Extract the output string from the dictionary + for (i = start; dict[i] != EOS && dict[i] != dict[1]; i = i + 1) { + if (i - start + 1 > maxch) + break + outstr[i - start + 1] = dict[i] + } + outstr[i - start + 1] = EOS + + # Return index for output string + return (count) +end diff --git a/pkg/xtools/catquery/doc/README b/pkg/xtools/catquery/doc/README new file mode 100644 index 00000000..f17920ab --- /dev/null +++ b/pkg/xtools/catquery/doc/README @@ -0,0 +1,322 @@ + CATQUERY: The Catalog and Survey Access Routines + +1. Introduction + + The catquery package provides a set of routines for local and remote +catalog and image survey server access. The supported catalogs and image +surveys are described in records stored in a catalog and image survey +configuration file respectively. The catalog and image survey records +specify the network address, the query format, and the output format for +each supported catalog or image display server. More detailed information +about catalogs and image survey access and configuration files can be +found by typing "help catalogs" and "help surveys". + + The results of each catalog query are stored in memory in an IRAF spool +file. Calling programs can access the catalog results sequentially or randomly +by record number. Individual fields in each record can be decoded into +floating point, integer, or string values. + +The results of each image survey query are written to an image file on disk, +currently a fits image file. IRAF image i/o routines can be used to access +the image. There must be enough space availale on the disk to receive the +image. + + +2. The Interface Routines + +The package prefix is cq. The interface routines are listed below. + + cq = cq_map (file, mode) + ival = cq_stati (cq, param) + cq_stats (cq, param, str, maxch) + nlines = cq_statt (cq, param, text, maxch) + + catno = cq_locate (cq, name) + catno = cq_locaten (cq, catno, catname, maxch) + catno = cq_setcat (cq, name) + catno = cq_setcatn (cq, catno) + + [ird]val = cq_fget[ird] (cq, name) + nelems = cq_fga[ird] (cq, name, array[ird], max_nelems) + cq_fgstr (cq, name, str, maxch) + cq_fgwrd (cq, name, wrd, maxch) + nlines = cq_fgtext (cq, name, text, maxch) + stat = cq_scan (cq) + + nqpars = cq_nqpars (cq) + qparno = cq_gqpar (cq, name, qpname, max_qpname, qpvalue, + max_qpvalue, qpunits, max_qpunits, qpformat, + max_qpformat) + qparno = cq_gqparn (cq, qparno, qpname, max_qpname, qpvalue, + max_qpvalue, qpunits, max_qpunits, qpformat, max_qpformat) + qparno = cq_sqpar (cq, name, valuestr) + qparno = cq_sqparn (cq, qparno, valuestr) + + res = cq_query (cq) + res = cq_fquery (cq, catfile, cathdr) + ival = cq_rstati (res, param) + cq_rstats (res, param, str, maxch) + nlines = cq_rstatt (res, param, text, maxch) + hparno = cq_hinfo (res, name, hpvalue, max_hpvalue) + hparno = cq_hinfon (res, hparno, hpname, max_hpname, hpvalue, + max_hpvalue) + nchars = cq_grecord (res, buffer, maxch, recno) + nchars = cq_gnrecord (res, buffer, maxch, nextrec) + fieldno = cq_finfo (res, name, foffset, fsize, ftype, funits, + max_funits, formats, max_formats) + fieldno = cq_finfon (res, fieldno, fname, max_fname, foffset, fsize, + ftype, funits, max_funits, formats, max_formats) + cq_rclose (res) + nchars = cq_gval[silrd] (res, name, [silrd]val) + nchars = cq_gvalc (res, name, str, maxch) + + imres = cq_imquery (cq, imname) + imres = cq_fimquery (cq, imname) + ival = cq_istati (imres, param) + cq_istats (imres, param, str, maxch) + nlines = cq_istatt (imres, param, text, maxch) + wparno = cq_winfo (imres, name, wkname, max_wkname, wvalue, + max_wvalue, wtype, wunits, max_wunits) + wparno = cq_winfon (imres, wparno, wpname, max_wpnane, wkname, + max_wkname, wvalue, max_wvalue, wtype, wunits, max_wunits) + kparno = cq_kinfo (imres, name, skname, max_skname, svalue, + max_svalue, stype, sunits, max_sunits) + kparno = cq_kinfon (imres, kparno, spname, max_spname, skname, + max_skname, svalue, max_svalue, stype, sunits, max_sunits) + cq_imclose (imres) + + cq_unmap (cq) + + +3. Notes + + An "include <pkg/cq.h>" statement must appear in the calling program to +make the catquery pacakge parameter definitions visible to the calling program. + + A "-lxtools" must be included in the calling program link line to link in +the catquery routines. + + The catalog and image surveys configuration files are mapped and unmapped +with the routines cq_map and cq_unmap. + + Before making a query the calling program must set the current catalog +or image survey with the cq_setcat or cq_setcatn routines, and format +and set the query parameters with the cq_gqpar, cq_gqparn, and cq_sqparn +routines. + + Remote and locate catalog queries are made with the cq_query routine. +The routines cq_rstat[ist] are used to retrieve the catalog results parameters. +Header parameter values and field descriptions can be retrieved with +the cq_hinfo / cq_hinfon and cq_finfo / cq_finfon routines respectively. +Catalog records can be accessed sequentially or randomly with the cq_gnrecord +and cq_grecord routines. The cq_gval[csilrd] routines can be used to decode +the record fields into floating point, integer, or string values. The +cq_fquery routine is used to make a catalog file emulate the results of a +catalog query. Cq_rclose frees the catalog results descriptor. + + Remote and locate image survey queries are made with the cq_imquery routine. +The routines cq_istat[ist] are used to retrieve the survey results parameters. +The standard wcs and image parameter descriptions can be retrieved with the +the cq_winfo / cq_winfon and cq_kinfo / cq_kinfon routines respectively. The +cq_fimquery routine is used to make an existing image emulate the results of +an image survey query. Cq_imclose frees the survey results descriptor. + +4. Examples + +Example 1: Query a catalog and dump the results to a catalog file. + + include <cq.h> + + .... + + ra = clgetd ("ra") + dec = clgetd ("dec") + width = clgetd ("width") + + .... + + # Open the catalog configuration file. + cq = cq_map ("astromz$lib/catdb.dat", READ_ONLY) + if (cq == NULL) + ... + + # Set the catalog. + catno = cq_setcat (cq, "noao@usno2") + if (catno == 0) + ... + + # Set the query parameters. Assume the input input units match the + # the expected units. The input size is a width so divide by two + # if the query expects a radius. + nqpars = cq_nqpars (cq) + do i = 1, nqpars { + parno = cq_gqparn (cq, i, qpname, CQ_SZ_QPNAME, qpvalue, + CQ_SZ_QPVALUE, qpunits, CQ_SZ_QPUNITS, qpformats + CQ_SZ_QPFORMATS) + if (parno != i) + next + if (streq (qpname, "ra")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (ra) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "dec")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (dec) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "radius")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width / 2.0d0) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "width")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "xwidth")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "ywidth")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } + } + + # Make the query. + res = cq_query (cq) + if (res == NULL) + ... + + # Write the results to a file. + recptr = 0 + while (cq_gnrecord (res, buffer, SZ_LINE, rectpr) != EOF) { + call fprintf (outfd, "%s") + call pargstr (buffer) + } + + # Close the query. + call cq_rclose (res) + + # Close the database. + call cq_unmap (cq) + + +Example 2: Repeat the previous example but only output records for + which magnitude values <= 16.0. + + include <cq.h> + + ... + + res = cq_query (cq) + if (res == NULL) + ... + + nrec = cq_rstati (res, CQNRECS) + do i = 1, nrecs { + nchars = cq_gvalr (res, i, "mag1", mag) + if (nchars <= 0) + next + if (mag > 16.0) + next + nchars = cq_grecord (res, buffer, SZ_LINE, i) + if (nchars <= 0) + next + call fprintf (outfd, "%s") + call pargstr (buffer) + } + + call cq_rclose (res) + + ... + + +Example 3: Make an image survey query and dump the results to a fits file. + + include <cq.h> + + .... + + ra = clgetd ("ra") + dec = clgetd ("dec") + width = clgetd ("width") + + .... + + # Open the catalog configuration file. + cq = cq_map ("astromz$lib/imdb.dat", READ_ONLY) + if (cq == NULL) + ... + + # Set the catalog. + catno = cq_setcat (cq, "dss1@cadc") + if (catno == 0) + ... + + # Set the query parameters. Assume the input input units match the + # the expected units. + nqpars = cq_nqpars (cq) + do i = 1, nqpars { + parno = cq_gqparn (cq, i, qpname, CQ_SZ_QPNAME, qpvalue, CQ_SZ_QPVALUE, + qpunits, CQ_SZ_QPUNITS, qpformats, CQ_SZ_QPFORMATS) + if (parno != i) + next + if (streq (qpname, "ra")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (ra) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "dec")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (dec) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "width")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "xwidth")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "ywidth")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } + } + + # Make the query. + imres = cq_imquery (cq, "outimage.fits") + if (imres == NULL) + ... + + # Free the results structure + call cq_imclose (imres) + + # Unmap the database + call cq_unmap (cq) + + + +Example 4: Repeat the previous example but convert the dss wcs to a fits wcs. +At_mkdss is a routine which converts a dss wcs to a fits wcs + + ... + + # Make the query. + imres = cq_imquery (cq, "outimage.fits") + if (imres == NULL) + ... + + wcstype = cq_istati (imres, CQWCS) + if (wcstype == CQWDSS) { + im = immap ("outimage.fits", READ_WRITE, 0) + stat = at_mkdss (im, true, false) + if (stat == ERR) + ... + call imunmap (im) + } + + # Free the results structure + call cq_imclose (imres) + + ... diff --git a/pkg/xtools/catquery/doc/catalogs.hlp b/pkg/xtools/catquery/doc/catalogs.hlp new file mode 100644 index 00000000..4109f810 --- /dev/null +++ b/pkg/xtools/catquery/doc/catalogs.hlp @@ -0,0 +1,233 @@ +.help catalogs Mar00 astromz +.ih +NAME +catalogs -- describe the catalog configuration file +.ih +USAGE +help catalogs +.ih +CATALOGS + +A catalog is a large set of tabular data records from which smaller +tabular data sets can be extracted by issuing a catalog server query. Catalogs +may be installed locally or accessed remotely. Installing a catalog involves +creating a record in the catalog configuration file which specifies the +catalog network address, the catalog query format, and the catalog query +output format. In the following sections the configuration file is +described in the context of accessing astrometric catalogs. + +.ih +THE CATALOG CONFIGURATION FILE + +A record in the catalog configuration file specifies the network address, +the query format, and the output format of each supported catalog server. +Catalog server records names have the form "catalog@site", +e.g. "usno2@noao". Adding support for a new catalog server or responding +to changes in the behavior of an already supported server requires either adding +a new record to the configuration file or changing an existing record in +the configuration file. It does not require changing the catalog +access code. + +The catalog server network address tells the catalog access code where +and how to connect to the network. Each network address has the syntax +"domain:port:address:flags" e.g. "inet:80:www.noao.edu:text". + +The query format specifies the form of the query server string, and the +names, default values, units, and format of the query parameters. A set of +query parameter names are reserved for accessing astrometric catalogs +including "ra", "dec", "radius", "hwidth", "width", "rawidth", "decwidth", +rahwidth, and dechwidth. The names of these parameters are not part of the +catalog access API. Other types of catalogs may have different reserved +query parameter names. The user replaces the default query values with user +query parameter values before making the query. + +The server query output format specifies the form of the expected server output: +including the data stream type, the record size, and the name, location, +size, data type, units and format of each field in the record. A set of +standard field names is reserved for accessing the output of astrometric +catalog servers including "id", "ra", "dec", and "mag[1-n]". These standard +field names are not part of the catalog access API. Other catalog +types may have a different set of standard field names in the future. + +.ih +SAMPLE CATALOG RECORD + +The following two examples illustrate typical catalog configuration file +records. Note that both records can be used to access the same catalog +data. The first example accesses the catalog as simple text, the latter +as blocked text. + +.nf +Example 1: Accessing the catalog as simple text. + +begin susno2@noao +address inet:80:www.noao.edu:text +query GET /cgi-bin/usno/usnoextract?search=yes&ra=%-s&dec=%-s&width=%-s HTTP/1.0 +\n\n +nquery 4 + ra 00:00:00.00 hours %0.2h + dec 00:00:00.0 degrees %0.1h + radius 5.0 minutes %0.1f + qsystem J2000.0 INDEF %s +type stext + hskip 10 + tskip 6 + recsize 0 + triml 0 + trimr 4 +nheader 1 + csystem J2000.0 +nfields 4 + ra 1 0 d hours %12.3h + dec 2 0 d degrees %12.2h + mag1 3 0 r INDEF %4.1f + mag2 4 0 r INDEF %4.1f +.fi + +.nf +Example 2: Accessing the catalog as blocked text. + +begin busno2@noao +address inet:80:www.noao.edu:text +query GET /cgi-bin/usno/usnoextract?search=yes&ra=%-s&dec=%-s&width=%-s HTTP/1.0 +\n\n +nquery 4 + ra 00:00:00.00 hours %0.2h + dec 00:00:00.0 degrees %0.1h + radius 5.0 minutes %0.1f + qsystem J2000.0 INDEF %s +type btext + hskip 10 + tskip 6 + recsize 44 + triml 0 + trimr 4 +nheader 1 + csystem J2000.0 +nfields 4 + ra 1 13 d hours %12.3h + dec 14 14 d degrees %12.2h + mag1 28 6 r INDEF %4.1f + mag2 34 6 r INDEF %4.1f +.fi + +The beginning of a new catalog record is indicated by a line of the form +\fI"begin catname"\fR where catname is a unique name of the form +\fI"catalog@site"\fR. If there is more than one record with the same +name, the last record is the one that is read. The same catalog server +may be accessed in more than one way by creating multiple records. +For example if the catalog server supports an optional magnitude selection +feature, then in one record this feature can be enabled and in another it +can be disabled. + +The \fIaddress\fR, \fIquery\fR and \fInquery\fR keywords are required and +define the network address, query command, format and query parameters for +the catalog. + +The \fIaddress\fR keyword "domain", "port", and "flags" fields are almost +always "inet", "80", and "text" respectively, so in most cases the only +address keyword field that has to be filled in is the address +field "www.noao.edu" in this case. + +The \fIquery\fR keyword defines the query command whose form is server +dependent. The query parameter values are encoded via the %-s formatting +strings. The calling program must encode the user query parameter values +into a set a strings which then replace the -%s format statement in the +query string. + +The number of query parameters is defined by the \fInquery\fR keyword. The +number of query parameters must be greater than or equal to the number of "-%s" +strings in the query keyword value. The name, default value, units, +and format of each query parameter are listed below the nquery keyword, +one query parameter description per line. The query parameters should +be defined in the catalog configuration file in the same order that they +appear in the query keyword value. Alert readers will notice that in +the examples above the number of query parameters is 4 but there are only +3 "%-s" strings in the query keyword value. In these examples the qsystem +query parameter, which defines the coordinate system of the ra and dec query +parameter values is fixed at J2000. For some servers this parameter may +be a true query parameter, i.e. the server may accept coordinates in +B1950 or J2000 or some other coordinate system. + +For astrometric catalogs the reserved query parameter names "ra", "dec", and +"qysystem" should be used to define the extraction region center and its +coordinate system, and one or more of "radius", "width", "xwidth", and +"ywidth" should be used to define the extraction region size. The units +of "ra" should be "hours", "degrees", or "radians", the units of dec +should be "degrees" or "radians", and units of the size query parameter +should be "degrees" or "minutes". The qsystem parameter value may be +any one of the supported celestial coordinate systems. The most common +qsystem values are "icrs", "J2000", or "B1950". The query parameter +formats are used to convert numerical values supplied by the calling +program to string values that can be passed to the query string. +It should be emphasized that the reserved query parameter names and units +are conventions that are adopted to simplify writing the configuration +file and astrometric applications. They are not part of the catalog +access API itself. + +The \fItype\fR keyword defines the form of the query output. The current options +are "stext" for simple text and "btext" for blocked text. Simple text +contains newline delimited records with whitespace delimited fields. +Blocked text contains newline delimited records and fixed position and size +fields. If the type keyword is missing "stext" is assumed. + +The \fIrecsize\fR keyword is the length of the record in characters including +the newline character. If the record size is variable recsize should be set +t0 0. If undefined the recsize keyword defaults to 0 for variable record +size. + +The \fIhskip\fR, \fItskip\fR, \fIltrim\fR, and \fItrim\fR define the number +of leading and trailing records in the query output to sky, and the +number of leading and trailing characters in each record to trim, i.e. +replace with blanks. If absent these keywords default to zero. + +The \fInheader\fR keyword defines the number of header keywords. Header +keyword values are global quantities which apply to the catalog server +output as a whole. There may be 0 or many header keywords. + +For most astrometry catalog the most important and often only header keyword +is \fIcsystem\fR which defines the coordinate system of the query output +coordinates, i.e. if csystem is "J2000" then the coordinates of objects +extracted from the catalog are in "J2000". + +The \fInfields\fR keyword defines the number of fields in the query output +records. The name, offset, size, datatype, units, and format of each field +follow, one field description per line. For simple text files the offset +is field or column number and the size is 0 meaning undefined. For blocked +text files the offset is the 1-indexed position of the first character (which +may be blank) in the field and size is the field size in characters where +the field size includes trailing blanks. Using a blocked text description may +be required for dealing with fields containing embedded blanks. The type +defines the preferred data type of a field. In the examples above the ra and +dec are assigned double precision data types. This means that for precision +reasons the calling program should but is not required to read these +quantities into double precision variables. The units information is +used to perform any required coordinate conversions, and the format information +is used in cases where the calling program must decode a field, perform +some numerical operation on it, and reencode it with the original precision. + +For astrometric catalogs the reserved standard field names "id", "ra", "dec", +"mag#" etc should be used to define the standard field names. The current +standard field name list is \fIid\fR, \fIra\fR, \fIdec\fR, \fRera\fR, +\fIedec\fR, \fIpmra\fR, \fIpmdec\fR, \fIepmra\fR, \fIepmdec\fR, +\fIcatsystem\fR, \fIequinox\fR, \fIepoch\fR, \fIpx\fR, \fIrv\fR, \fIepx\fR, +\fIerv\fR, \fImag\fR, \fIcolor\fR, \fIemag\fR, \fIecolor\fR, \fIxp\fR, +\fIyp\fR, \fIxc\fR, \fIyc\fR, \fIexc\fR, \fIeyc\fR, \fIimag\fR, and \fIeimag\fR. +At a minimum an astrometric catalog must contain the "ra" and "dec" fields. +The units of the ra field must be "hours", "degrees", or "radians" +and the units of the "dec" field must be "degrees" or "radians". The +other standard fields are optional and define quantities like: proper +motions in ra and dec, the coordinate system, equinox, and epoch +of observation, parallax, radial velocity, magnitude and color information, +and predicted image pixel coordinates. The definitions and default units +for all these quantities are defined more fully in the help for the +astrometry package. It should be emphasized that the reserved field names +and units names are conventions that are adopted to simplify writing the +configuration file and astrometric applications. They are not part of +the catalog access API itself. + + +.ih +SEE ALSO +surveys +.endhelp diff --git a/pkg/xtools/catquery/doc/catquery.hd b/pkg/xtools/catquery/doc/catquery.hd new file mode 100644 index 00000000..1ae79114 --- /dev/null +++ b/pkg/xtools/catquery/doc/catquery.hd @@ -0,0 +1,56 @@ +# Help directory for the CATQUERY library + +$doc = "./" +$source = "../" + +cqmap hlp=doc$cqmap.hlp, src=source$cqmap.x +cqstati hlp=doc$cqstati.hlp, src=source$cqstat.x +cqstats hlp=doc$cqstats.hlp, src=source$cqstat.x +cqstatt hlp=doc$cqstatt.hlp, src=source$cqstat.x +cqlocate hlp=doc$cqlocate.hlp, src=source$cqlocate.x +cqlocaten hlp=doc$cqlocaten.hlp, src=source$cqlocate.x +cqsetcat hlp=doc$cqsetcat.hlp, src=source$cqsetcat.x +cqsetcatn hlp=doc$cqsetcatn.hlp, src=source$cqsetcat.x +cqget hlp=doc$cqget.hlp, src=source$cqget.x + +cqnqpars hlp=doc$cqnqpars.hlp, src=source$cqnqpars.x +cqgqpar hlp=doc$cqgqpar.hlp, src=source$cqgqpar.x +cqgqparn hlp=doc$cqgqparn.hlp, src=source$cqgqpar.x +cqsqpar hlp=doc$cqsqpar.hlp, src=source$cqsqpar.x +cqsqparn hlp=doc$cqsqparn.hlp, src=source$cqsqpar.x + +cqquery hlp=doc$cqquery.hlp, src=source$cqquery.x +cqfquery hlp=doc$cqfquery.hlp, src=source$cqquery.x +cqrstati hlp=doc$cqrstati.hlp, src=source$cqrstat.x +cqrstats hlp=doc$cqrstats.hlp, src=source$cqrstat.x +cqrstatt hlp=doc$cqrstatt.hlp, src=source$cqrstat.x +cqhinfo hlp=doc$cqhinfo.hlp, src=source$cqrinfo.x +cqhinfon hlp=doc$cqhinfon.hlp, src=source$cqrinfo.x +cqfinfo hlp=doc$cqfinfo.hlp, src=source$cqrinfo.x +cqfinfon hlp=doc$cqfinfon.hlp, src=source$cqrinfo.x +cqgrecord hlp=doc$cqgrecord.hlp, src=source$cqrecords.x +cqgnrecord hlp=doc$cqgnrecord.hlp, src=source$cqrecords.x +cqgvalc hlp=doc$cqgvalc.hlp, src=source$cqgfields.x +cqgvals hlp=doc$cqgvals.hlp, src=source$cqgfields.x +cqgvali hlp=doc$cqgvali.hlp, src=source$cqgfields.x +cqgvall hlp=doc$cqgvall.hlp, src=source$cqgfields.x +cqgvalr hlp=doc$cqgvalr.hlp, src=source$cqgfields.x +cqgvald hlp=doc$cqgvald.hlp, src=source$cqgfields.x +cqrclose hlp=doc$cqrclose.hlp, src=source$cqquery.x + +cqimquery hlp=doc$cqimquery.hlp, src=source$cqimquery.x +cqfimquery hlp=doc$cqfimquery.hlp, src=source$cqimquery.x +cqistati hlp=doc$cqistati.hlp, src=source$cqistat.x +cqistats hlp=doc$cqistats.hlp, src=source$cqistat.x +cqistatt hlp=doc$cqistatt.hlp, src=source$cqistat.x +cqwinfo hlp=doc$cqwinfo.hlp, src=source$cqiminfo.x +cqwinfon hlp=doc$cqwinfon.hlp, src=source$cqiminfo.x +cqkinfo hlp=doc$cqkinfo.hlp, src=source$cqiminfo.x +cqkinfon hlp=doc$cqkinfon.hlp, src=source$cqiminfo.x +cqimclose hlp=doc$cqimclose.hlp, src=source$cqimquery.x + +cqunmap hlp=doc$cqunmap.hlp, src=source$cqmap.x + +ccsystems hlp=doc$ccsystems.hlp +catalogs hlp=doc$catalogs.hlp +surveys hlp=doc$surveys.hlp diff --git a/pkg/xtools/catquery/doc/catquery.hlp b/pkg/xtools/catquery/doc/catquery.hlp new file mode 100644 index 00000000..3521c62c --- /dev/null +++ b/pkg/xtools/catquery/doc/catquery.hlp @@ -0,0 +1,322 @@ +.help catquery Aug01 xtools +.ih +NAME +catquery -- catalog access package +.ih +SYNOPSIS + +.nf + cq = cq_map (file, mode) + ival = cq_stati (cq, param) + cq_stats (cq, param, str, maxch) + nlines = cq_statt (cq, param, text, maxch) + + catno = cq_locate (cq, name) + catno = cq_locaten (cq, catno, catname, maxch) + catno = cq_setcat (cq, name) + catno = cq_setcatn (cq, catno) + + [ird]val = cq_fget[ird] (cq, name) + nelems = cq_fga[ird] (cq, name, array[ird], max_nelems) + cq_fgstr (cq, name, str, maxch) + cq_fgwrd (cq, name, wrd, maxch) + nlines = cq_fgtext (cq, name, text, maxch) + stat = cq_scan (cq) + + nqpars = cq_nqpars (cq) + qparno = cq_gqpar (cq, name, qpname, max_qpname, qpvalue, + max_qpvalue, qpunits, max_qpunits, qpformat, + max_qpformat) + qparno = cq_gqparn (cq, qparno, qpname, max_qpname, qpvalue, + max_qpvalue, qpunits, max_qpunits, qpformat, max_qpformat) + qparno = cq_sqpar (cq, name, valuestr) + qparno = cq_sqparn (cq, qparno, valuestr) + + res = cq_query (cq) + res = cq_fquery (cq, catfile, cathdr) + ival = cq_rstati (res, param) + cq_rstats (res, param, str, maxch) + nlines = cq_rstatt (res, param, text, maxch) + hparno = cq_hinfo (res, name, hpvalue, max_hpvalue) + hparno = cq_hinfon (res, hparno, hpname, max_hpname, hpvalue, + max_hpvalue) + nchars = cq_grecord (res, buffer, maxch, recno) + nchars = cq_gnrecord (res, buffer, maxch, nextrec) + fieldno = cq_finfo (res, name, foffset, fsize, ftype, funits, + max_funits, formats, max_formats) + fieldno = cq_finfon (res, fieldno, fname, max_fname, foffset, fsize, + ftype, funits, max_funits, formats, max_formats) + cq_rclose (res) + nchars = cq_gval[silrd] (res, name, [silrd]val) + nchars = cq_gvalc (res, name, str, maxch) + + imres = cq_imquery (cq, imname) + imres = cq_fimquery (cq, imname) + ival = cq_istati (imres, param) + cq_istats (imres, param, str, maxch) + nlines = cq_istatt (imres, param, text, maxch) + wparno = cq_winfo (imres, name, wkname, max_wkname, wvalue, + max_wvalue, wtype, wunits, max_wunits) + wparno = cq_winfon (imres, wparno, wpname, max_wpnane, wkname, + max_wkname, wvalue, max_wvalue, wtype, wunits, max_wunits) + kparno = cq_kinfo (imres, name, skname, max_skname, svalue, + max_svalue, stype, sunits, max_sunits) + kparno = cq_kinfon (imres, kparno, spname, max_spname, skname, + max_skname, svalue, max_svalue, stype, sunits, max_sunits) + cq_imclose (imres) + + cq_unmap (cq) +.fi +.ih +DESCRIPTION +The catquery package provides a set of routines for local and remote +catalog and image survey server access. The supported catalogs and image +surveys are described in records stored in a catalog and image survey +configuration file respectively. The catalog and image survey records +specify the network address, the query format, and the output format for +each supported catalog or image display server. More detailed information +about catalogs and image survey access and configuration files can be +found by typing "help catalogs" and "help surveys". + +The results of each catalog query are stored in memory in an IRAF spool file. +Calling programs can access the catalog results sequentially or randomly +by record number. Individual fields in each record can be decoded into +floating point, integer, or string values. + +The results of each image survey query are written to an image file on disk, +currently a fits image file. IRAF image i/o routines can be used to access +the image. There must be enough space availale on the disk to receive the +image. + +.ih +NOTES + +The catquery package definitions file is cq.h. + +The catalog and image surveys configuration files are mapped and unmapped +with the routines cq_map and cq_unmap. + +Before making a query the calling program must set the current catalog +or image survey with the cq_setcat or cq_setcatn routines, and format +and set the query parameters with the cq_gqpar, cq_gqparn, and cq_sqparn +routines. + +Remote and locate catalog queries are made with the cq_query routine. +The routines cq_rstat[ist] are used to retrieve the catalog results parameters. +Header parameter values and field descriptions can be retrieved with +the cq_hinfo, cq_hinfon, cq_finfo, and cq_finfon routines. Catalog records +can be accessed sequentially or randomly with the cq_gnrecord and +cq_grecord routines. The cq_gval[csilrd] routines can be used to decode +the record fields into floating point, integer, or string values. +The cq_fquery routine is used to make a catalog file emulate +the results of a catalog query. Cq_rclose frees the catalog results descriptor. + +Remote and locate image survey queries are made with the cq_imquery routine. +The routines cq_istat[ist] are used to retrieve the survey results parameters. +The standard wcs and image parameter descriptions can be retrieved with the +the cq_winfo, cq_winfon, cq_kinfo, and cq_kinfon routines. The cq_fimquery +routine is used to make an existing image emulate the results of an image +survey query. Cq_imclose frees the survey results descriptor. + +.ih +EXAMPLES +.nf +Example 1: Query a catalog and dump the results to a catalog file. + + include <cq.h> + + .... + + ra = clgetd ("ra") + dec = clgetd ("dec") + width = clgetd ("width") + + .... + + # Open the catalog configuration file. + cq = cq_map ("astromz$lib/catdb.dat", READ_ONLY) + if (cq == NULL) + ... + + # Set the catalog. + catno = cq_setcat (cq, "noao@usno2") + if (catno == 0) + ... + + # Set the query parameters. Assume the input units match the + # the expected units. The input size is a width so divide by two + # if the query expects a radius. + nqpars = cq_nqpars (cq) + do i = 1, nqpars { + parno = cq_gqparn (cq, i, qpname, CQ_SZ_QPNAME, qpvalue, + CQ_SZ_QPVALUE, qpunits, CQ_SZ_QPUNITS, qpformats + CQ_SZ_QPFORMATS) + if (parno != i) + next + if (streq (qpname, "ra")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (ra) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "dec")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (dec) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "radius")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width / 2.0d0) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "width")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "xwidth")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "ywidth")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } + } + + # Make the query. + res = cq_query (cq) + if (res == NULL) + ... + + # Write the results to a file. + recptr = 0 + while (cq_gnrecord (res, buffer, SZ_LINE, rectpr) != EOF) { + call fprintf (outfd, "%s") + call pargstr (buffer) + } + + # Close the query. + call cq_rclose (res) + + # Close the database. + call cq_unmap (cq) + + +Example 2: Repeat the previous example but only output records for + which magnitude values <= 16.0. + + include <cq.h> + + ... + + res = cq_query (cq) + if (res == NULL) + ... + + nrec = cq_rstati (res, CQNRECS) + do i = 1, nrecs { + nchars = cq_gvalr (res, i, "mag1", mag) + if (nchars <= 0) + next + if (mag > 16.0) + next + nchars = cq_grecord (res, buffer, SZ_LINE, i) + if (nchars <= 0) + next + call fprintf (outfd, "%s") + call pargstr (buffer) + } + + call cq_rclose (res) + + ... + + +Example 3: Make an image survey query and dump the results to a fits file. + + include <cq.h> + + .... + + ra = clgetd ("ra") + dec = clgetd ("dec") + width = clgetd ("width") + + .... + + # Open the catalog configuration file. + cq = cq_map ("astromz$lib/imdb.dat", READ_ONLY) + if (cq == NULL) + ... + + # Set the catalog. + catno = cq_setcat (cq, "dss1@cadc") + if (catno == 0) + ... + + # Set the query parameters. Assume the input units match the + # the expected units. + nqpars = cq_nqpars (cq) + do i = 1, nqpars { + parno = cq_gqparn (cq, i, qpname, CQ_SZ_QPNAME, qpvalue, CQ_SZ_QPVALUE, + qpunits, CQ_SZ_QPUNITS, qpformats, CQ_SZ_QPFORMATS) + if (parno != i) + next + if (streq (qpname, "ra")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (ra) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "dec")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (dec) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "width")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "xwidth")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } else if (streq (qpname, "ywidth")) { + call sprintf (qpvalue, CQ_SZ_QPVALUE, qpformats) + call pargd (width) + parno = cq_sqpars (cq, qpname, qpvalue) + } + } + + # Make the query. + imres = cq_imquery (cq, "outimage.fits") + if (imres == NULL) + ... + + # Free the results structure + call cq_imclose (imres) + + # Unmap the database + call cq_unmap (cq) + + + +Example 4: Repeat the previous example but convert the dss wcs to a fits wcs. + At_mkdss is a routine which converts a dss wcs to a fits wcs + + ... + + # Make the query. + imres = cq_imquery (cq, "outimage.fits") + if (imres == NULL) + ... + + wcstype = cq_istati (imres, CQWCS) + if (wcstype == CQWDSS) { + im = immap ("outimage.fits", READ_WRITE, 0) + stat = at_mkdss (im, true, false) + if (stat == ERR) + ... + call imunmap (im) + } + + # Free the results structure + call cq_imclose (imres) + + ... +.fi +.endhelp diff --git a/pkg/xtools/catquery/doc/catquery.men b/pkg/xtools/catquery/doc/catquery.men new file mode 100644 index 00000000..ace43e7c --- /dev/null +++ b/pkg/xtools/catquery/doc/catquery.men @@ -0,0 +1,28 @@ + cqmap - Map the catalog / survey configuration file + cqstat[ist] - Get an integer, string, or text catalog / survey parameter + cqlocate[n] - Locate a catalog / survey by name or number + cqsetcat[n] - Set the current catalog / survey by name or number + cqget - Read catalog / survey configuration file keywords directly + + cqnqpars - Get the number of query parameters + cqgqpar[n] - Get query parameter info by name or number + cqsqpar[n] - Set query parameter value by name or number + + cqquery - Query a catalog and return the results + cqfquery - Query a catalog file and return the results + cqrstat[ist] - Get catalog results integer, string, or text parameter + cqhinfo[n] - Get catalog results header value by name or number + cqgrecord - Get catalog results record + cqgnrecord - Get next catalog results record + cqfinfo[n] - Get catalog results field info by name or number +cqgval[csilrd] - Get field value from record + cqrclose - Close the catalog results + + cqimquery - Query an image survey and return the results + cqfimquery - Query an image file and return the results + cqistat[ist] - Get survey results integer, string, or text parameter + cqwinfo[n] - Get survey results wcs parameter info by name or number + cqkinfo[n] - Get survey results image parameter info by name or number + cqimclose - Close the survey results + + cqunmap - Unmap the configuration file diff --git a/pkg/xtools/catquery/doc/ccsystems.hlp b/pkg/xtools/catquery/doc/ccsystems.hlp new file mode 100644 index 00000000..3c1235a6 --- /dev/null +++ b/pkg/xtools/catquery/doc/ccsystems.hlp @@ -0,0 +1,134 @@ +.help ccsystems Mar00 catquery +.ih +NAME +ccsystems -- list and describe the supported sky coordinate systems +.ih +USAGE +help ccsystems + +.ih +SKY COORDINATE SYSTEMS + +The sky package supports the equatorial ("fk4", "fk4-noe", "fk5", "icrs"), +ecliptic, galactic, and supergalactic celestial coordinate systems. In most +cases and unless otherwise noted users can input their coordinates in +any one of these systems as long as they specify the coordinate system +correctly. + +Considerable flexibility is permitted in how the coordinate systems are +specified, e.g. J2000.0, j2000.0, 2000.0, fk5, fk5 J2000, and fk5 2000.0 +all specify the mean place post-IAU 1976 or FK5 system. Missing equinox and +epoch fields assume reasonable defaults. In most cases the +systems of most interest to users are "icrs", "j2000", and "b1950" +which stand for the ICRS J2000.0, FK5 J2000.0 and FK4 B1950.0 celestial +coordinate systems respectively. The full set of options are listed below: + +.ls equinox [epoch] +The equatorial mean place post-IAU 1976 (FK5) system if equinox is a +Julian epoch, e.g. J2000.0 or 2000.0, or the equatorial mean place +pre-IAU 1976 system (FK4) if equinox is a Besselian epoch, e.g. B1950.0 +or 1950.0. Julian equinoxes are prefixed by a J or j, Besselian equinoxes +by a B or b. Equinoxes without the J / j or B / b prefix are treated as +Besselian epochs if they are < 1984.0, Julian epochs if they are >= 1984.0. +Epoch is the epoch of the observation and may be a Julian +epoch, a Besselian epoch, or a Julian date. Julian epochs +are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to the epoch type of +equinox if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls icrs [equinox] [epoch] +The International Celestial Reference System where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk5 [equinox] [epoch] +The equatorial mean place post-IAU 1976 (FK5) system where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system where equinox is a +Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. Epoch +is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls noefk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system but without the E-terms +where equinox is a Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. If undefined epoch defaults to equinox. +.le +.ls apparent epoch +The equatorial geocentric apparent place post-IAU 1976 system where +epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. +.le +.ls ecliptic epoch +The ecliptic coordinate system where epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch values < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. +.le +.ls galactic [epoch] +The IAU 1958 galactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le +.ls supergalactic [epoch] +The deVaucouleurs supergalactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le + +Fields enclosed in [] are optional with the defaults as described. The epoch +field for the "icrs" , "fk5", "galactic", and "supergalactic" coordinate +systems is only used if the input coordinates are in the equatorial fk4, +noefk4, fk5, or icrs systems and proper motions are used to transform from +coordinate system to another. + +.ih +SEE ALSO +.endhelp diff --git a/pkg/xtools/catquery/doc/cqfimquery.hlp b/pkg/xtools/catquery/doc/cqfimquery.hlp new file mode 100644 index 00000000..d344c7ee --- /dev/null +++ b/pkg/xtools/catquery/doc/cqfimquery.hlp @@ -0,0 +1,39 @@ +.help cqfimquery Mar00 "Catquery Package" +.ih +NAME +cqfimquery -- return the results of an image file query +.ih +SYNOPSIS + +imres = cq_fimquery (cq, imname) + +.nf +pointer cq # the configuration file descriptor +char imname # the input image file name +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls imname +The file name of the image being queried. +.le +.ih +DESCRIPTION +Cq_fimquery queries an existing image and returns a results descriptor. +Cq_fimquery is a pointer procedure which returns the results descriptor +as its function value. NULL is returned if an error occurs in the query +or the image does not exist. + +Cq_fimquery is used to make an image emulate the results of an image +survey query. +.ih +NOTES +Cq_setcat with the image survey name set to the reserved record name +"imname@noao" must be called before any image survey query is made. + +.ih +SEE ALSO +cqimquery, cqimclose +.endhelp diff --git a/pkg/xtools/catquery/doc/cqfinfo.hlp b/pkg/xtools/catquery/doc/cqfinfo.hlp new file mode 100644 index 00000000..b3bce18a --- /dev/null +++ b/pkg/xtools/catquery/doc/cqfinfo.hlp @@ -0,0 +1,85 @@ +.help cqfinfo Mar00 "Catquery Package" +.ih +NAME +cqfinfo -- get the requested description by name +.ih +SYNOPSIS + +fieldno = cq_finfo (res, name, fname, max_fname, foffset, fsize, ftype, funits, + max_funits, format, max_format) + +.nf +pointer res # the results descriptor +char name # the input field name +char fname # the returned field name +int max_fname # the maximum size of the field name +int foffset # the returned field offset +int fsize # the returned field size +int ftype # the returned field type +char funits # the returned field units +int max_funits # the maximum size of the field units +char format # the returned field format +int max_format # the maximum size of the field format +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls name +The name of the requested field. +.le +.ls fname +The returned field name. +.le +.ls max_fname +The maximum size of the returned field name. +.le +.ls foffset +The returned field offset. Foffset is the field or column number if the +results are in simple text format, or the one-indexed field offset in chars +if the results are in blocked text format. +.le +.ls fsize +The returned field size. Fsize is zero if the results are in simple text format, +the field width in characters if the results are in blocked file format. +.le +.ls ftype +The returned field data type. The options are TY_DOUBLE, TY_REAL, TY_LONG, +TY_INT, TY_SHORT, and TY_CHAR. +.le +.ls funits +The returned field units. +.le +.ls max_funits +The maximum size of the returned field units. +.le +.ls format +The returned field format. +.le +.ls max_format +The maximum size of the returned field format. +.le +.ih +DESCRIPTION +Cq_finfo returns the name, offset, size, data type, units, and format of +the requested field. Cq_finfo is an integer function which returns +the field number of the requested field as its function value. + +.ih +NOTES + +Related routines of interest are: + +.nf +fieldno = cq_fnumber (res, fname) +foffset = cq_foffset (res, fname) + fsize = cq_fsize (res, fname) + ftype = cq_ftype (res, fname) + call cq_funits (res, fname, units, max_units) + call cq_ffmts (res, fname, format, max_format) +.fi +.ih +SEE ALSO +cqfinfon +.endhelp diff --git a/pkg/xtools/catquery/doc/cqfinfon.hlp b/pkg/xtools/catquery/doc/cqfinfon.hlp new file mode 100644 index 00000000..62f07dfd --- /dev/null +++ b/pkg/xtools/catquery/doc/cqfinfon.hlp @@ -0,0 +1,79 @@ +.help cqfinfon Mar00 "Catquery Package" +.ih +NAME +cqfinfon -- get the catalog results field description by number +.ih +SYNOPSIS + +fieldno = cq_finfon (res, fieldno, fname, max_fname, foffset, fsize, ftype, + funits, max_funits, format, max_format) + +.nf +pointer res # the results descriptor +int fieldno # the sequence number of the field to be returned +char fname # the returned field name +int max_fname # the maximum size of the returned field name +int foffset # the field offset +int fsize # the field size +int ftype # the field data type +char funits # the field units +int max_funits # the maximum size of the returned field units +char format # the field format +int max_format # the maximum size of the returned field format +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls fieldno +The sequence number of the field for which information is to be returned. +.le +.ls fname +The returned field name. +.le +.ls max_fname +The maximum size of the returned field name. +.le +.ls foffset +The field offset. Foffset is the field or column number if the +results are in simple text format, or the one-indexed field offset in chars +if the results are in blocked text format. +.le +.ls fsize +The field size. Fsize is zero if the results are in simple text file format, +the field width in characters if results are in blocked file format. +.le +.ls ftype +The field data type. The options are TY_DOUBLE, TY_REAL, TY_LONG, TY_INT, +TY_SHORT, and TY_CHAR. +.le +.ls units +The returned field units string. +.le +.ls max_units +The maximum size of the returned field units string. +.le +.ls format +The returned field format string. +.le +.ls max_format +The maximum size of the returned field format string. +.le +.ih +DESCRIPTION +Cq_finfon returns the name, offset, size, data type, units, and format of +the requested field. Cq_finfon is an integer function which returns +the field number of the requested field as its function value. + +.ih +NOTES +Related routines of interest are: + +.nf +call cq_fname (res, fieldno, name, max_name) +.fi +.ih +SEE ALSO +cqfinfo +.endhelp diff --git a/pkg/xtools/catquery/doc/cqfquery.hlp b/pkg/xtools/catquery/doc/cqfquery.hlp new file mode 100644 index 00000000..32f2d5b0 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqfquery.hlp @@ -0,0 +1,78 @@ +.help cqfquery Mar00 "Catquery Package" +.ih +NAME +cqfquery -- query a catalog file and return the results +.ih +SYNOPSIS + +res = cq_fquery (cq, catfile, hdrtxt) + +.nf +pointer cq # the configuration file descriptor +char catfile # the catalog file name +char hdrtext # the catalog file header text +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls catfile +The catalog file name. +.le +.ls hdrtext +Text describing the format of the catalog file. +.le +.ih +DESCRIPTION +Cq_fquery is a pointer function which returns the results descriptor as its +function value. NULL is returned if an error occurs in the catalog file query. + +Cq_fquery is used to make a catalog file emulate the results of +a catalog query. The calling program must supply the catalog format +description. A sample catalog file and catalog description are shown below. +.ih +NOTES +Cq_setcat with the catalog name set to the reserved record name "filename@noao" +must be called before any catalog file query is made. + +A sample catalog file is shown below. + +.nf + 00:00:01.443 -0:06:57.52 13.5 15.2 + 00:00:01.574 -0:05:33.26 16.1 18.0 + 00:00:01.904 -0:09:48.51 18.2 19.6 + 00:00:02.529 -0:04:21.53 13.4 14.4 + 00:00:04.154 -0:01:56.32 17.1 18.3 + 00:00:04.438 -0:05:00.03 11.4 13.5 + 00:00:04.697 -0:03:24.59 16.9 17.7 + 00:00:05.989 -0:02:46.36 15.1 17.6 + 00:00:07.118 -0:09:03.53 19.1 19.8 + 00:00:07.260 -0:06:47.95 17.0 17.7 + 00:00:07.314 -0:00:22.35 15.3 16.8 +.fi + +The accompanying catalog file header is shown below. + +.nf +type stext +nheader 1 + csystem J2000 +nfields 4 + ra 1 0 d hours %12.3h + dec 2 0 d degrees %12.2h + mag1 3 0 r INDEF %4.1f + mag2 4 0 r INDEF %4.1f +.fi + +The catalog header specifies the type of file, "stext" for simple text in +this example, the number of header parameters, the number of fields in each +record, and the individual field descriptions. + +More information about the catalog header shown here can be found by typing +"help catalogs". + +.ih +SEE ALSO +cqquery, cqrclose +.endhelp diff --git a/pkg/xtools/catquery/doc/cqget.hlp b/pkg/xtools/catquery/doc/cqget.hlp new file mode 100644 index 00000000..0229cdc1 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqget.hlp @@ -0,0 +1,130 @@ +.help cqget Mar00 "Catquery Package" +.ih +NAME +cqget -- read configuration file keywords directly +.ih +SYNOPSIS + +.nf + [ird]val = cq_fget[ird](cq, fname) + nelems = cq_fga[ird](cq, fname, [ird]array, max_nelems) + call cq_fgwrd (cq, fname, wrd, maxch) + call cq_fgstr (cq, fname, str, maxch) + nlines = cq_fgtext (cq, fname, text, maxch) + stat = cq_scan (cq) + +pointer cq # the configuration file descriptor +char fname # the field or keyword to be located +int iarray # the returned integer array +int rarray # the returned real array +int darray # the returned double array +int max_nelems # the maximum size of the returned array +char wrd # the keyword word value to be read +char str # the keyword string value to be read +char text # the keyword text value to be read +int maxch # the maximum size of the word, string, text value +.fi +.ih +SYNOPSIS +.ls cq +The configuration file descriptor. +.le +.ls fname +The name of the field or keyword to be read. +.le +.ls [ird]array +The integer, real, or double array returned by a call to cq_fga[ird]. +.le +.ls max_nelems +The maximum number of elements in the array returned by a call to +cq_fga[ird]. +.le +.ls wrd, str, text +The word, string, or text value returned by a call to cq_fgwrd, cq_fgstr, or +cq_fgtext. +.le +.ls maxch +The maximum number of characters in the word, string, or text returned +by cq_fgwrd, cq_fgstr, cq_fgtext. +.le +.ih +DESCRIPTION + +Cq_fgval[ird] is an integer, real, or double function which returns the +integer, real, or double value of the requested field or keyword as its +function value. + +Cq_fga[ird] returns an integer, real, or double array for the requested +field. Cq_fga[ird] is an integer function which returns the number of elements +in the retrieved array as its function value. + +Cq_fg[wrd/str/text] returns the next word, the entire string, or the +number of lines in the requested keyword. Cq_fgtext is an integer function +which returns the number of lines in the returned text as its functions +value. + +.ih +NOTES +The cqget routines are used to read keywords or fields in the current catalog +or survey directly. The routines cq_setcat or cq_setcatn must be called before +the cqget routines can be used. + +The cqget routines must be error checked to avoid task termination. +.ih +EXAMPLES + +Sample catalog configuration file record. + +.nf +begin usno2@noao +address inet:80:www.noao.edu:text +query GET /cgi-bin/usno/usnoextract?search=yes&ra=%-s&dec=%-s&width=%-s HTTP/1.0 +\n\n +nquery 4 + ra 00:00:00.00 hours %0.2h + dec 00:00:00.0 degrees %0.1h + radius 5.0 minutes %0.1f + qsystem J2000.0 INDEF %s +type stext + hskip 10 + tskip 6 + recsize 44 + triml 0 + trimr 4 +nheader 1 + csystem J2000.0 +nfields 4 + ra 1 0 d hours %12.3h + dec 2 0 d degrees %12.2h + mag1 3 0 r INDEF %4.1f + mag2 4 0 r INDEF %4.1f +.fi + +Example 1: To fetch the query field which includes embedded blanks use cq_fgstr. + +.nf +call cq_fgstr (cq, "query", buffer, SZ_LINE) +.fi + +Example 2: To fetch the type field use cq_fgwrd. + +.nf +call cq_fgwrd (cq, "type", buffer, SZ_LINE) +.fi + +Example 3: To determine the number of query parameters. + +.nf +nquery = cq_fgeti (cq, "nquery") +.fi + +Example4: To return a text array which follows a numerically valued parameter. + +.nf +nquery = cq_fgeti (cq, "nquery") +nlines = cq_fgtext (cq, "nquery", buffer, nquery * SZ_LINE) +.fi + +.ih +SEE ALSO +.endhelp diff --git a/pkg/xtools/catquery/doc/cqgnrecord.hlp b/pkg/xtools/catquery/doc/cqgnrecord.hlp new file mode 100644 index 00000000..6fd9ab53 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqgnrecord.hlp @@ -0,0 +1,61 @@ +.help cqgnrecord Mar00 "Catquery Package" +.ih +NAME +cqgnrecord -- get the next record from the catalog results +.ih +SYNOPSIS + +stat = cq_gnrecord (res, buf, maxch, nextrec) + +.nf +pointer res # the results descriptor +char buf # the output record buffer +int maxch # the maximum size of the output record buffer +int recno # the next available record number +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls buf +The buffer containing the returned record. +.le +.ls maxch +The maximum size of the output buffer. +.le +.ls recptr +The next available record number. Recptr is updated after each call. +.le +.ih +DESCRIPTION +Cq_gnrecord returns the requested record. Cq_grecord is an integer function +which returns BOF, the number of characters in the record, or EOF as +its function value. + +.ih +NOTES +In most cases allocating a buffer size that is SZ_LINE chars long +will be adequate to hold the output record. If the integer results parameter +CQRECSIZE is defined, i.e. non-zero, then an output buffer CQRECSIZE chars +long can be allocated. + +.ih +EXAMPLES + +pointer cq_query() +int cq_gnrecord() + +... + +res = cq_query (cq) +recno = 0 +while (cq_gnrecord (res, record, SZ_LINE, recno) != EOF) { + call printf ("%s") + call pargstr (record) +} +call cq_rclose (res) +.ih +SEE ALSO +cqgrecord +.endhelp diff --git a/pkg/xtools/catquery/doc/cqgqpar.hlp b/pkg/xtools/catquery/doc/cqgqpar.hlp new file mode 100644 index 00000000..72b14809 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqgqpar.hlp @@ -0,0 +1,72 @@ +.help cqgqpar Mar00 "Catquery Package" +.ih +NAME +cqgqpar -- get a query parameter description by name +.ih +SYNOPSIS + +parno = cq_gqpar (cq, pname, qpname, max_qpname, qpvalue, max_qpvalue, qpunits, + max_qpunits, qpformat, max_qpformat) + +.nf +pointer cq # the configuration file descriptor +char pname # the name of the requested query parameter +char qpname # the returned query parameter name +int max_qpname # the maximum size of the returned parameter name +char qpvalue # the returned query parameter value +int max_qpvalue # the maximum size of the returned parameter value +char qpunits # the returned query parameter units +int max_qpunits # the maximum size of the returned parameter units +char qpformat # the returned query parameter format +int max_qpformat # the maximum size of the returned parameter format +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls pname +The name of the requested query parameter. +.le +.ls qpname +The returned query parameter name. +.le +.ls max_qpname +The maximum size of the returned query parameter name. +.le +.ls qpvalue +The returned query parameter value. +.le +.ls max_qpvalue +The maximum size of the returned query parameter value. +.le +.ls qpunits +The returned query parameter units. +.le +.ls max_qpunits +The maximum size of the returned query parameter units. +.le +.ls qpformat +The returned query parameter format. +.le +.ls max_qpformat +The maximum size of the returned query parameter format. +.le +.ih +DESCRIPTION +Cq_gqpar returns the name, value, units, and format of the requested query +parameter. Cq_gpar is an integer function which returns the sequence number +of the query parameter as its function value. Zero is returned if the requested +query parameter is not found. +.ih +NOTES +Cq_setcat or cq_setcatn must be called before a query parameter +request can be made. + +The defined constants CQ_SZ_QPNAME, CQ_SZ_QPVALUE, CQ_SZ_QPUNITS, and +CQ_SZ_QPFMTS in the cq.h file can be used to assign values to the +max_qpname, max_qpvalue, max_qpunits, and max_qpformat paramters. +.ih +SEE ALSO +cqnqpars, cqgqparn, cqsqpar, cqsqparn +.endhelp diff --git a/pkg/xtools/catquery/doc/cqgqparn.hlp b/pkg/xtools/catquery/doc/cqgqparn.hlp new file mode 100644 index 00000000..10155fe7 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqgqparn.hlp @@ -0,0 +1,73 @@ +.help cqgqparn Mar00 "Catquery Package" +.ih +NAME +cqgqparn -- get the query parameter description by sequence number +.ih +SYNOPSIS + +parno = cq_gqparn (cq, parno, qpname, max_qpname, qpvalue, max_qpvalue, qpunits, + max_qpunits, qpformat, max_qpformat) + +.nf +pointer cq # the configuration file descriptor +int parno # the query parameter sequence number +char qpname # the returned query parameter name +int max_qpname # the maximum size of the returned parameter name +char qpvalue # the returned query parameter value +int max_qpvalue # the maximum size of the returned parameter value +char qpunits # the returned query parameter units +int max_qpunits # the maximum size of the returned parameter units +char qpformat # the returned query parameter format +int max_qpformat # the maximum size of the returned parameter format +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls parno +The query parameter sequence number. +.le +.ls qpname +The returned query parameter name. +.le +.ls max_qpname +The maximum size of the returned query parameter name. +.le +.ls qpvalue +The returned query parameter value. +.le +.ls max_qpvalue +The maximum size of the returned query parameter value. +.le +.ls qpunits +The returned query parameter units. +.le +.ls max_qpunits +The maximum size of the returned query parameter units. +.le +.ls qpformat +The returned query parameter format. +.le +.ls max_qpformat +The maximum size of the returned query parameter format. +.le +.ih +DESCRIPTION +Cq_gqparn returns the name, value, units, and format of the requested query +parameter by number. Cq_gparn is an integer function which returns the +sequence number of the query parameter as its function value. Zero is +returned if the requested query parameter is not found. +.ih +NOTES +Cq_setcat or cq_setcatn must be called before a query parameter +request can be made. + +The defined constants CQ_SZ_QPNAME, CQ_SZ_QPVALUE, CQ_SZ_QPUNITS, and +CQ_SZ_QPFMTS in the cq.h file can be used to assign values to the +max_qpname, max_qpvalue, max_qpunits, and max_qpformat paramters. + +.ih +SEE ALSO +cqnqpars, cqgqpar, cqsqpar, cqsqparn +.endhelp diff --git a/pkg/xtools/catquery/doc/cqgrecord.hlp b/pkg/xtools/catquery/doc/cqgrecord.hlp new file mode 100644 index 00000000..732f43f5 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqgrecord.hlp @@ -0,0 +1,46 @@ +.help cqgrecord Mar00 "Catquery Package" +.ih +NAME +cqgrecord -- get a record from the catalog results +.ih +SYNOPSIS + +stat = cq_grecord (res, buf, maxch, recno) + +.nf +pointer res # the results descriptor +char buf # the output buffer +int maxch # the maximum size of the output buffer +int recno # the record to be fetched +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls buf +The buffer containing the returned record. +.le +.ls maxch +The maximum size of the output buffer. +.le +.ls recptr +The sequence number of the record to be fetched. Recptr should be set to +to initialize sequential reading of all the catalog results. +.le +.ih +DESCRIPTION +Cq_grecord returns the requested record. Cq_grecord is an integer function +which returns BOF, the number of characters in the record, or EOF as +its function value. +.ih +NOTES +In most cases allocating a buffer size that is SZ_LINE chars long +will be adequate to hold the output record. If the integer results parameter +CQRECSIZE is defined, i.e. non-zero, then an output buffer CQRECSIZE chars +long can be allocated. + +.ih +SEE ALSO +cqgnrecord +.endhelp diff --git a/pkg/xtools/catquery/doc/cqgvalc.hlp b/pkg/xtools/catquery/doc/cqgvalc.hlp new file mode 100644 index 00000000..a6313556 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqgvalc.hlp @@ -0,0 +1,42 @@ +.help cqgvalc Mar00 "Catquery Package" +.ih +NAME +cqgvalc -- get a catalog results field as a string value +.ih +SYNOPSIS +nchars = cq_gvalc (res, recno, fname, str, maxch) + +.nf +pointer res # the results descriptor +int recno # the record number +char fname # the field name +char str # the returned string value +int maxch # the maximum size of the returned string value +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls recno +The record number. +.le +.ls fname +The field name. +.le +.ls str +Array containing returned string value. +.le +.ls maxch +The maximum size in characters of the returned string value. +.le +.ih +DESCRIPTION +Cq_gvalc returns the requested field value as a string. Cq_gvalc is an +integer function which returns the number of decoded characters as its +function value. Zero is returned if the field could not be decoded. + +.ih +SEE ALSO +cqgval[silrd] +.endhelp diff --git a/pkg/xtools/catquery/doc/cqgvald.hlp b/pkg/xtools/catquery/doc/cqgvald.hlp new file mode 100644 index 00000000..245371cb --- /dev/null +++ b/pkg/xtools/catquery/doc/cqgvald.hlp @@ -0,0 +1,40 @@ +.help cqgvald Mar00 "Catquery Package" +.ih +NAME +cqgvald -- get a catalog results field as a double precision value +.ih +SYNOPSIS + +nchars = cq_gvald (res, recno, fname, dval) + +.nf +pointer res # the results descriptor +int recno # the record number +char fname # the field name +double dval # the returned field value +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls recno +The record number. +.le +.ls fname +The field name. +.le +.ls dval +The returned double precision value. +.le +.ih +DESCRIPTION +Cq_gvald returns the requested field as a double precision value. +Cq_gvald is an integer function which returns the number of characters +that were successfully decoded as its function value. Zero is returned +if the requested field could not be decoded. + +.ih +SEE ALSO +cqgval[csilr] +.endhelp diff --git a/pkg/xtools/catquery/doc/cqgvali.hlp b/pkg/xtools/catquery/doc/cqgvali.hlp new file mode 100644 index 00000000..8d5d3606 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqgvali.hlp @@ -0,0 +1,40 @@ +.help cqgvali Mar00 "Catquery Package" +.ih +NAME +cqgvali -- get a catalog results field as an integer +.ih +SYNOPSIS + +nchars = cq_gvali (res, recno, fname, ival) + +.nf +pointer res # the results descriptor +int recno # the record number +char fname # the field name +int ival # the returned field value +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls recno +The record number. +.le +.ls fname +The field name. +.le +.ls ival +The returned integer value. +.le +.ih +DESCRIPTION +Cq_gvali returns the requested field as an integer value. +Cq_gvali is an integer function which returns the number of characters +that were successfully decoded as its function value. Zero is returned +if the requested field could not be decoded. + +.ih +SEE ALSO +cqgval[cslrd] +.endhelp diff --git a/pkg/xtools/catquery/doc/cqgvall.hlp b/pkg/xtools/catquery/doc/cqgvall.hlp new file mode 100644 index 00000000..0571850f --- /dev/null +++ b/pkg/xtools/catquery/doc/cqgvall.hlp @@ -0,0 +1,40 @@ +.help cqgvall Mar00 "Catquery Package" +.ih +NAME +cqgvall -- get the catalog results field as a long integer value +.ih +SYNOPSIS + +nchars = cq_gvall (res, recno, fname, lval) + +.nf +pointer res # the results descriptor +int recno # the record number +char fname # the field name +long lval # the returned field value +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls recno +The record number. +.le +.ls fname +The field name. +.le +.ls lval +The returned long integer value. +.le +.ih +DESCRIPTION +Cq_gvall returns the requested field as a long integer value. +Cq_gvall is an integer function which returns the number of characters +that were successfully decoded as its function value. Zero is returned +if the requested field could not be decoded. + +.ih +SEE ALSO +cqgval[csird] +.endhelp diff --git a/pkg/xtools/catquery/doc/cqgvalr.hlp b/pkg/xtools/catquery/doc/cqgvalr.hlp new file mode 100644 index 00000000..f7229841 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqgvalr.hlp @@ -0,0 +1,40 @@ +.help cqgvalr Mar00 "Catquery Package" +.ih +NAME +cqgvalr -- get the catalog results field as a real value +.ih +SYNOPSIS + +nchars = cq_gvalr (res, recno, fname, rval) + +.nf +pointer res # the results descriptor +int recno # the record number +char fname # the field name +real rval # the returned field value +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls recno +The record number. +.le +.ls fname +The field name. +.le +.ls rval +The returned real value. +.le +.ih +DESCRIPTION +Cq_gvalr returns the requested field as a real value. +Cq_gvalr is an integer function which returns the number of characters +that were successfully decoded as its function value. Zero is returned +if the requested field could not be decoded. + +.ih +SEE ALSO +cqgval[csild] +.endhelp diff --git a/pkg/xtools/catquery/doc/cqgvals.hlp b/pkg/xtools/catquery/doc/cqgvals.hlp new file mode 100644 index 00000000..90f39544 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqgvals.hlp @@ -0,0 +1,41 @@ +.help cqgvals Mar00 "Catquery Package" +.ih +NAME +cqgvals -- get the catalog results field as a short integer +.ih +SYNOPSIS +include <cq.h> + +nchars = cq_gvals (res, recno, fname, sval) + +.nf +pointer res # the results descriptor +int recno # the record number +char fname # the field name +short sval # the returned field value +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls recno +The record number. +.le +.ls fname +The field name. +.le +.ls sval +The returned short integer value. +.le +.ih +DESCRIPTION +Cq_gvals returns the requested field as a short integer value. +Cq_gvals is an integer function which returns the number of characters +that were successfully decoded as its function value. Zero is returned +if the requested field could not be decoded. + +.ih +SEE ALSO +cqgval[cilrd] +.endhelp diff --git a/pkg/xtools/catquery/doc/cqhinfo.hlp b/pkg/xtools/catquery/doc/cqhinfo.hlp new file mode 100644 index 00000000..62db280c --- /dev/null +++ b/pkg/xtools/catquery/doc/cqhinfo.hlp @@ -0,0 +1,39 @@ +.help cqhinfo Mar00 "Catquery Package" +.ih +NAME +cqhinfo -- get catalog results header parameter value by name +.ih +SYNOPSIS + +hparno = cq_hinfo (res, hname, hvalue, max_hvalue) + +.nf +pointer res # the results descriptor +char hname # the results header parameter name +char hvalue # the returned header parameter value +int max_hvalue # the maximum size of the header parameter value +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls hname +The name of the results header parameter for which the value is to be returned. +.le +.ls hvalue +The returned results header parameter value. +.le +.ls max_hvalue +The maximum size of the returned results header parameter value. +.le +.ih +DESCRIPTION +Cq_hinfo returns the value of the requested header parameter. Cq_hinfo is +an integer function which returns the header parameter sequence number +as its function value. Zero is returned if the header parameter +cannot be found. +.ih +SEE ALSO +cqhinfon +.endhelp diff --git a/pkg/xtools/catquery/doc/cqhinfon.hlp b/pkg/xtools/catquery/doc/cqhinfon.hlp new file mode 100644 index 00000000..2654ce50 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqhinfon.hlp @@ -0,0 +1,47 @@ +.help cqhinfon Mar00 "Catquery Package" +.ih +NAME +cqhinfon -- get a catalog results header parameter value by number +.ih +SYNOPSIS + +hparno = cq_hinfon (res, hparno, hname, max_hname, hvalue, max_hvalue) + +.nf +pointer res # the results descriptor +int hparno # the results header parameter sequence number +char hname # the returned results header parameter name +int max_hname # the maximum size of the header parameter name +char hvalue # the returned header parameter value +int max_hvalue # the maximum size of the header parameter value +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls hparno +The requested results header parameter sequence number. +.le +.ls hname +The returned name of the results header parameter. +.le +.ls max_hname +The maximum size of the results header parameter name. +.le +.ls hvalue +The returned results header parameter value. +.le +.ls max_hvalue +The maximum size of the results header parameter value. +.le +.ih +DESCRIPTION +Cq_hinfon returns the name and value of the requested results header +parameter. Cq_hinfon is an integer function which returns the +sequence number of the requested parameter as its function value. +Zero is returned if the results header parameter is not found. +.ih +SEE ALSO +cqhinfo +.endhelp diff --git a/pkg/xtools/catquery/doc/cqimclose.hlp b/pkg/xtools/catquery/doc/cqimclose.hlp new file mode 100644 index 00000000..4c3d105b --- /dev/null +++ b/pkg/xtools/catquery/doc/cqimclose.hlp @@ -0,0 +1,24 @@ +.help cqimclose Mar00 "Catquery Package" +.ih +NAME +cqimclose -- free the survey results descriptor +.ih +SYNOPSIS + +call cq_imclose (imres) + +.nf +pointer imres # the results descriptor +.fi +.ih +ARGUMENTS +.ls imres +The survey results descriptor. +.le +.ih +DESCRIPTION +Cq_imclose frees the survey results descriptor. +.ih +SEE ALSO +cqimquery, cqfimquery +.endhelp diff --git a/pkg/xtools/catquery/doc/cqimquery.hlp b/pkg/xtools/catquery/doc/cqimquery.hlp new file mode 100644 index 00000000..12e71506 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqimquery.hlp @@ -0,0 +1,44 @@ +.help cqimquery Mar00 "Catquery Package" +.ih +NAME +cqimquery -- query the image survey and return the results +.ih +SYNOPSIS + +imres = cq_imquery (cq, imname) + +.nf +pointer cq # the configuration file descriptor +pointer imname # the name of the output image file +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls imname +The name of the output image file. At the output image produced by an +image survey query must be a single FITS image. The image name +should include the suffix ".fits" in order to make the image +visible to IRAF image i/o. +.le +.ih +DESCRIPTION +Cq_imquery queries the image survey, creates an output image file, and +returns the survey results descriptor. Cq_imquery is a pointer function +which returns the survey results descriptor as its function value. +Null is returned if an error occurs in the survey query. +.ih +NOTES +Cq_setcat or cq_setcatn must be called before any catalog or image +survey query can be made. + +Cq_nqpars and either cq_gqpar or cq_gqparn must be called to determine +the number of query parameters and get each query parameter description. + +Cq_sqpar or cq_sqparn must be called to replace the default query parameter +values with the calling program values. +.ih +SEE ALSO +cqfimquery, cqimclose +.endhelp diff --git a/pkg/xtools/catquery/doc/cqistati.hlp b/pkg/xtools/catquery/doc/cqistati.hlp new file mode 100644 index 00000000..beeec2c9 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqistati.hlp @@ -0,0 +1,49 @@ +.help cqistati Mar00 "Catquery Package" +.ih +NAME +cqistati -- get an image survey results integer parameter +.ih +SYNOPSIS +include <cq.h> + +ival = cq_istati (imres, parameter) + +.nf +pointer imres # the survey results descriptor +int parameter # the parameter to be returned +.fi +.ih +ARGUMENTS +.ls imres +The survey results descriptor. +.le +.ls parameter +The survey parameter to be returned. The currently supported survey +parameters defined in cq.h are: +.nf +CQINQPARS # the number of query params used to produce results +CQIMTYPE # the image results type, CQFITS +CQIMRECSIZE # the image record size, 0 if undefined +CQIMHSKIP # the number of leading bytes to skip, 0 if undefined +CQIMHREAD # the number of leading dummy reads, 0 if undefined +CQWCS # the image wcs status, CQ_WFITS or CQ_WDSS or CQ_WNONE +CQNWCS # the number of wcs parameters, 0 if none defined +CQNIMPARS # the number of image parameters, 0 if none defined +.fi +.le +.ih +DESCRIPTION +Cq_istati returns the values of image survey results integer parameters. +Cq_istati is an integer function which returns the value of the requested +parameter as its function value. + +.ih +NOTES +More information about the image survey results parameters and their +relationship to the parent image survey is available by typing +"help surveys". + +.ih +SEE ALSO +cq_istats, cq_istatt +.endhelp diff --git a/pkg/xtools/catquery/doc/cqistats.hlp b/pkg/xtools/catquery/doc/cqistats.hlp new file mode 100644 index 00000000..700717f0 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqistats.hlp @@ -0,0 +1,56 @@ +.help cqistats Mar00 "Catquery Package" +.ih +NAME +cqistats -- get an image survey results string parameter +.ih +SYNOPSIS +include <cq.h> + +call cq_istats (imres, parameter, str, maxch) + +.nf +pointer imres # the image survey results descriptor +int parameter # the parameter to be returned +char str # the returned string parameter value +int maxch # the maximum size of the string parameter +.fi +.ih +ARGUMENTS +.ls res +The image survey results descriptor. +.le +.ls parameter +The image survey results parameter to be returned. The currently supported +image survey parameters defined in cq.h are: + +.nf +CQIMCATDB # the name of the parent configuration file +CQIMCATNAME # the name of the parent image survey +CQIMADDRESS # the network address used to produce the results +CQIMQUERY # the query used to produce the results +CQIMNAME # the output image name +CQIQPNAMES # the results query parameter dictionary +CQIQPVALUES # the results query parameter values dictionary +CQIQPUNITS # the results query parameter units dictionary +.fi +.le +.ls str +Array containing returned string parameter value. +.le +.ls maxch +The maximum size in characters of the returned string value. +.le +.ih +DESCRIPTION +Cq_istats returns the values of image survey results string parameters. + +.ih +NOTES +More information about the image survey results parameters and their +relationship to the parent image survey is available by typing +"help surveys". + +.ih +SEE ALSO +cq_istati, cq_istatt +.endhelp diff --git a/pkg/xtools/catquery/doc/cqistatt.hlp b/pkg/xtools/catquery/doc/cqistatt.hlp new file mode 100644 index 00000000..0af9fb4a --- /dev/null +++ b/pkg/xtools/catquery/doc/cqistatt.hlp @@ -0,0 +1,55 @@ +.help cqistatt Mar00 "Catquery Package" +.ih +NAME +cqistatt -- get an image survey results text parameter +.ih +SYNOPSIS +include <cq.h> + +nlines = cq_istatt (imres, parameter, text, maxch) + +.nf +pointer imres # the survey results descriptor +int parameter # the parameter to be returned +char text # the returned text parameter value +int maxch # the maximum size of the returned text parameter +.fi +.ih +ARGUMENTS +.ls imres +The results descriptor. +.le +.ls parameter +The image survey parameter to be returned. The currently supported text +image survey results text parameters defined in cq.h are: +.nf +CQIQPNAMES # the list of survey results query parameter names +CQIQPVALUES # the list of survey results query parameter values +CQIQPUNITS # the list of survey results query parameter units +.fi +.le +.ls text +String containing returned text parameter value. Text parameters differ +from string parameters only in that they contain embedded newline +characters. +.le +.ls maxch +The maximum size in characters of the returned text value. +.le +.ih +DESCRIPTION +Cq_istatt returns the values of catalog results string parameters. + +The buffer size for the returned text parameters can be estimated by getting +the value of the integer parameter CQRNQPARS, and multiplying it by the maximum +buffer sizes CQ_SZ_QPNAME, CQ_SZ_QPVALUE, CQ_SZ_QPUNITS respectively. + +.ih +NOTES +More information about the survey results parameters and their relationship +to the parent image survey is available by typing "help surveys". + +.ih +SEE ALSO +cq_istati, cq_istats +.endhelp diff --git a/pkg/xtools/catquery/doc/cqkinfo.hlp b/pkg/xtools/catquery/doc/cqkinfo.hlp new file mode 100644 index 00000000..30d869a8 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqkinfo.hlp @@ -0,0 +1,65 @@ +.help cqkinfo Mar00 "Catquery Package" +.ih +NAME +cqkinfo -- get the results standard image parameter description by name +.ih +SYNOPSIS + +ipno = cq_kinfo (imres, pname, pkname, max_pkname, pkvalue, max_pkvalue, + pktype, pkunits, max_pkunits) + +.nf +pointer imres # the survey results descriptor +char pname # the image parameter name +char pkname # the default image keyword name (INDEF if undefined) +int max_pkname # the maximum size of the keyword name +char pkvalue # the default parameter value (INDEF if undefined) +int max_pkvalue # the maximum size of the parameter value +int pktype # the parameter data type +char pkunits # the parameter units (INDEF if undefined) +int max_wpunits # the maximum size of the parameter units +.fi +.ih +ARGUMENTS +.ls imres +The image results descriptor. +.le +.ls pname +The name of the image parameter for which the description is to be returned. +.le +.ls pkname +The returned image parameter keyword name. Pkname is "INDEF" if undefined. +.le +.ls max_pkname +The maximum size of the returned image parameter keyword name. +.le +.ls pkvalue +The returned image parameter value. Pkvalue is "INDEF" if undefined. +.le +.ls max_pkvalue +The maximum size of the returned image parameter value. +.le +.ls pktype +The image parameter data type. The options are TY_DOUBLE, TY_REAL, TY_LONG, +TY_INT, TY_SHORT, and TY_CHAR. +.le +.ls pkunits +The returned image parameter units. Pkunits is "INDEF" if undefined. +.le +.ls max_pkunits +The maximum size of the returned image parameter units. +.le +.ih +DESCRIPTION +Cq_kinfo returns the keyword name, default value, data type, and units +of the requested standard image parameter. Cq_kinfo is an integer function +which returns the sequence number of the standard image parameter as its +function value. Zero is returned if the standard image parameter is not found. +.ih +NOTES +For more information about the standard image parameters and their relationship +to the image surveys configuration file type "help surveys". +.ih +SEE ALSO +cqkinfon +.endhelp diff --git a/pkg/xtools/catquery/doc/cqkinfon.hlp b/pkg/xtools/catquery/doc/cqkinfon.hlp new file mode 100644 index 00000000..e57f0d47 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqkinfon.hlp @@ -0,0 +1,73 @@ +.help cqkinfon Mar00 "Catquery Package" +.ih +NAME +cqkinfon -- get the results standard image parameter description by number +.ih +SYNOPSIS + +ipno = cq_kinfo (imres, ipno, pname, max_pname, pkname, max_pkname, pkvalue, + max_pkvalue, pktype, pkunits, max_pkunits) + +.nf +pointer imres # the survey results descriptor +int ipno # the image parameter sequence number +char pname # the image parameter name +int max_pname # the maximum size of the parameter name +char pkname # the default image keyword name (INDEF if undefined) +int max_pkname # the maximum size of the keyword name +char pkvalue # the default parameter value (INDEF if undefined) +int max_pkvalue # the maximum size of the parameter value +int pktype # the parameter data type +char pkunits # the parameter units (INDEF if undefined) +int max_wpunits # the maximum size of the parameter units +.fi +.ih +ARGUMENTS +.ls imres +The image results descriptor. +.le +.ls ipno +The sequence number of the requested parameter. +.le +.ls pname +The returned image parameter name. +.le +.ls max_pname +The maximum size of the returned parameter name. +.le +.ls pkname +The returned image parameter keyword name. Pkname is "INDEF" if undefined. +.le +.ls max_pkname +The maximum size of the returned image parameter keyword name. +.le +.ls pkvalue +The returned image parameter value. Pkvalue is "INDEF" if undefined. +.le +.ls max_pkvalue +The maximum size of the returned image parameter value. +.le +.ls pktype +The image parameter data type. The options are TY_DOUBLE, TY_REAL, TY_LONG, +TY_INT, TY_SHORT, and TY_CHAR. +.le +.ls pkunits +The returned image parameter units. Pkunits is "INDEF" if undefined. +.le +.ls max_pkunits +The maximum size of the returned image parameter units. +.le +.ih +DESCRIPTION +Cq_kinfon returns the keyword name, default value, data type, and units +of the requested standard image parameter. Cq_kinfon is an integer function +which returns the sequence number of the standard image parameter as its +function value. Zero is returned if the standard image parameter is not found. +.ih +NOTES +For more information about the standard image parameters and their relationship +to the image surveys configuration file type "help surveys". +.ih +SEE ALSO +cqkinfo +.endhelp diff --git a/pkg/xtools/catquery/doc/cqlocate.hlp b/pkg/xtools/catquery/doc/cqlocate.hlp new file mode 100644 index 00000000..12f7cbc0 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqlocate.hlp @@ -0,0 +1,35 @@ +.help cqlocate Mar00 "Catquery Package" +.ih +NAME +cqlocate -- locate a catalog / survey record by name +.ih +SYNOPSIS + +catno = cq_locate (cq, catname) + +.nf +pointer cq # the configuration file descriptor +char catname # the name of the catalog / survey record to be located +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls catname +The name of the catalog / survey record to be located. +.le +.ih +DESCRIPTION +Cq_locate locates a catalog / survey record in the configuration file by +name. Cq_locate is an integer function which returns the catalog / survey +record sequence number as its function value. Zero is returned if the catalog +record is not located. +.ih +Cq_locate is used to determine whether the requested record exists. It does +not set the current catalog / survey. This must be done with a call to +cq_setcat or cq_setcatn. +.ih +SEE ALSO +cqlocaten, cqsetcat, cqsetcatn +.endhelp diff --git a/pkg/xtools/catquery/doc/cqlocaten.hlp b/pkg/xtools/catquery/doc/cqlocaten.hlp new file mode 100644 index 00000000..ca7011b0 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqlocaten.hlp @@ -0,0 +1,47 @@ +.help cqlocaten Mar00 "Catquery Package" +.ih +NAME +cqlocaten -- locate a catalog / survey record by number +.ih +SYNOPSIS + +catno = cq_locaten (cq, catno, catname, maxch) + +.nf +pointer cq # the configuration file descriptor +int catno # the number of the catalog / survey to be located +char catname # the name of the located catalog +int maxch # the maximum size of the name of the located catalog +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls catno +The sequence number of the catalog / survey record to be located. +.le +.ls catname +The name of the located catalog. +.le +.ls maxch +The maximum size of the name of the located catalog. +.le +.ih +DESCRIPTION +Cq_locaten locates a catalog / survey record in the configuration file by +sequence number. Cq_locaten is an integer function which returns the catalog +/ survey record sequence number as its function value. Zero is returned +if the catalog record is not located. Cq_locaten also returns the name of the +located catalog in the array catname. + +.ih +NOTES +Cq_locaten is used to determine whether the requested record exists. It does +not set the current catalog / survey. This must be done with a call to +cq_setcat or cq_setcatn. + +.ih +SEE ALSO +cqlocate, cqsetcat, cqsetcatn +.endhelp diff --git a/pkg/xtools/catquery/doc/cqmap.hlp b/pkg/xtools/catquery/doc/cqmap.hlp new file mode 100644 index 00000000..1c87530d --- /dev/null +++ b/pkg/xtools/catquery/doc/cqmap.hlp @@ -0,0 +1,33 @@ +.help cqmap Mar00 "Catquery Package" +.ih +NAME +cq_map -- map the catalog / survey configuration file +.ih +SYNOPSIS +cq = cq_map (file, mode) + +.nf +char file # the catalog / survey configuration file +int mode # the file access mode +.fi +.ih +ARGUMENTS +.ls file +The name of the catalog / survey configuration file. +.le +.ls mode +The configuration file access mode. At present only READ_ONLY is supported. +.le +.ih +DESCRIPTION +Cq_map maps the record structure of the catalog / survey configuration file. +Cq_map is a pointer function which returns the configuration file descriptor +to the calling program. +.ih +NOTES +Cq_map returns a NULL configuration file descriptor if an error occurs in +the mapping process. +.ih +SEE ALSO +cqunmap +.endhelp diff --git a/pkg/xtools/catquery/doc/cqnqpars.hlp b/pkg/xtools/catquery/doc/cqnqpars.hlp new file mode 100644 index 00000000..63ac4ca8 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqnqpars.hlp @@ -0,0 +1,32 @@ +.help cqnqpars Mar00 "Catquery Package" +.ih +NAME +cqnqpars -- Get the number of query parameters +.ih +SYNOPSIS + +nqpars = cq_nqpars (cq) + +.nf +pointer cq # the configuration file descriptor +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ih +DESCRIPTION +Cq_nqpars returns the number of expected catalog / survey query parameters. +Cq_nqpars is an integer function which returns the number of expected +catalog / survey parameters as its function value. The number of query +parameters may be zero if the query is non-programmable. Not all query +parameters are programmable. +.ih +NOTES +The routines cq_setcat or cq_setcatn must be called before the number of +query parameters can be requested. +.ih +SEE ALSO +cqgqpar, cqgqparn, cqsqpar, cqsqparn +.endhelp diff --git a/pkg/xtools/catquery/doc/cqquery.hlp b/pkg/xtools/catquery/doc/cqquery.hlp new file mode 100644 index 00000000..797cd72c --- /dev/null +++ b/pkg/xtools/catquery/doc/cqquery.hlp @@ -0,0 +1,35 @@ +.help cqquery Mar00 "Catquery Package" +.ih +NAME +cqquery -- query a catalog and return the results +.ih +SYNOPSIS + +res = cq_query (cq) + +.nf +pointer cq # the configuration file descriptor +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ih +DESCRIPTION +Cq_query is a pointer function which returns the catalog results descriptor +as its function value. NULL is returned if an error occurs in the catalog +query. +.ih +NOTES +Cq_setcat or cq_setcatn must be called before any catalog query can be made. + +Cq_nqpars and either cq_gqpar or cq_gqparn must be called to determine the +number of query parameters and get each query parameter description. + +Cq_sqpar or cq_sqparn must be called to replace the default query parameter +values with the calling program values. +.ih +SEE ALSO +cqfquery, cqrclose +.endhelp diff --git a/pkg/xtools/catquery/doc/cqrclose.hlp b/pkg/xtools/catquery/doc/cqrclose.hlp new file mode 100644 index 00000000..98dfb4b5 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqrclose.hlp @@ -0,0 +1,24 @@ +.help cqrclose Mar00 "Catquery Package" +.ih +NAME +cqrclose -- free the catalog results descriptor +.ih +SYNOPSIS + +call cq_rclose (res) + +.nf +pointer res # the results descriptor +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ih +DESCRIPTION +Cq_rclose frees the results descriptor. +.ih +SEE ALSO +cqquery, cqfquery +.endhelp diff --git a/pkg/xtools/catquery/doc/cqrstati.hlp b/pkg/xtools/catquery/doc/cqrstati.hlp new file mode 100644 index 00000000..943a5218 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqrstati.hlp @@ -0,0 +1,53 @@ +.help cqrstati Mar00 "Catquery Package" +.ih +NAME +cqrstati -- get a catalog results integer parameter +.ih +SYNOPSIS +include <cq.h> + +ival = cq_rstati (res, parameter) + +.nf +pointer res # the results descriptor +int parameter # the parameter to be returned +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls parameter +The catalog results parameter to be returned. The currently supported +catalog results parameters defined in cq.h are: +.nf +CQRNQPARS # the number of query params used to produce results +CQRTYPE # the data type of the results, CQSTEXT or CQBTEXT +CQRNRECS # the number of records in the results +CQRECSIZE # the record size, 0 if undefined +CQRHSKIP # the number of header records to skip, 0 if undefined +CQRTSKIP # the number of trailer records to skip, 0 if undefined +CQRTRIML # the number of leading chars to skip, 0 if undefined +CQRTRIMR # the number of trailing chars to skip, 0 if undefined +CQNHEADER # the number of header keyword value pairs, 0 if none defined +CQNFIELDS # the number of fields in a record +CQRECPTR # the current record number, BOF or number or EOF +.fi +.le +.ih +DESCRIPTION + +Cq_rstati returns the values of catalog results integer parameters. +Cq_rstati is an integer function which returns the value of the requested +parameter as its function value. + +.ih +NOTES + +More information about the catalog results parameters and their relationship +to the parent catalog is available by typing "help catalogs". + +.ih +SEE ALSO +cqrstats, cqrstatt +.endhelp diff --git a/pkg/xtools/catquery/doc/cqrstats.hlp b/pkg/xtools/catquery/doc/cqrstats.hlp new file mode 100644 index 00000000..45487dfd --- /dev/null +++ b/pkg/xtools/catquery/doc/cqrstats.hlp @@ -0,0 +1,54 @@ +.help cqrstats Mar00 "Catquery Package" +.ih +NAME +cqsrtats -- get a catalog results string parameter +.ih +SYNOPSIS +include <cq.h> + +call cq_rstats (res, parameter, str, maxch) + +.nf +pointer res # the results descriptor +int parameter # the parameter to be returned +char str # the returned string parameter +int maxch # the maximum size of the returned string parameter +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls parameter +The catalog results parameter to be returned. The currently supported +catalog results parameters defined in cq.h are: + +.nf +CQRCATDB # the name of the parent configuration file +CQRCATNAME # the name of the parent catalog +CQRADDRESS # the network address used to produce the results +CQRQUERY # the network query used to produce the results +CQRQPNAMES # the results query parameter dictionary +CQRQPVALUES # the results query parameter values dictionary +CQRQPUNITS # the results query parameter units dictionary +.fi +.le +.ls str +Array containing returned string parameter value. +.le +.ls maxch +The maximum size in characters of the returned string parameter value. +.le +.ih +DESCRIPTION +Cq_rstats returns the values of catalog results string parameters. + +.ih +NOTES +More information about the catalog results parameters and their relationship +to the parent catalog is available by typing "help catalogs". + +.ih +SEE ALSO +cqrstati, cqrstatt +.endhelp diff --git a/pkg/xtools/catquery/doc/cqrstatt.hlp b/pkg/xtools/catquery/doc/cqrstatt.hlp new file mode 100644 index 00000000..cbb13c44 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqrstatt.hlp @@ -0,0 +1,56 @@ +.help cqrstatt Mar00 "Catquery Package" +.ih +NAME +cqrstatt -- get a catalog results text parameter +.ih +SYNOPSIS +include <cq.h> + +nlines = cq_rstatt (res, parameter, text, maxch) + +.nf +pointer res # the results descriptor +int parameter # the parameter to be returned +char text # the returned text parameter value +int maxch # the maximum size of the returned text parameter +.fi +.ih +ARGUMENTS +.ls res +The results descriptor. +.le +.ls parameter +The catalog results parameter to be returned. The currently supported +catalog results text parameters defined in cq.h are: + +.nf +CQRQPNAMES # the list of catalog results query parameter names +CQRQPVALUES # the list of catalog results query parameter values +CQRQPUNITS # the list of catalog results query parameter units +.fi +.le +.ls text +String containing returned text parameter value. Text parameters differ +from string parameters only in that they contain embedded newline +characters. +.le +.ls maxch +The maximum size in characters of the returned text value. +.le +.ih +DESCRIPTION +Cq_rstatt returns the values of catalog results string parameters. + +The buffer size for the returned text parameters can be estimated by getting +the value of the integer parameter CQRNQPARS, and multiplying it by the maximum + buffer sizes CQ_SZ_QPNAME, CQ_SZ_QPVALUE, CQ_SZ_QPUNITS respectively. + +.ih +NOTES +More information about the catalog results parameters and their relationship +to the parent catalog is available by typing "help catalogs". + +.ih +SEE ALSO +cq_rstati, cq_rstats +.endhelp diff --git a/pkg/xtools/catquery/doc/cqsetcat.hlp b/pkg/xtools/catquery/doc/cqsetcat.hlp new file mode 100644 index 00000000..1a6a4f62 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqsetcat.hlp @@ -0,0 +1,35 @@ +.help cqsetcat Mar00 "Catquery Package" +.ih +NAME +cqsetcat -- set the current catalog / survey by name +.ih +SYNOPSIS + +catno = cq_setcat (cq, catname) + +.nf +pointer cq # the configuration file descriptor +char catname # the name of the catalog to be set +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls catname +The name of the catalog / survey to be set. +.le +.ih +DESCRIPTION +Cq_setcat sets the current catalog. Cq_setcat is an integer function +which returns the sequence number of the requested catalog / survey as +its function value. Zero is returned if the requested catalog / survey +cannot be set. +.ih +NOTES +Cq_setcat or cq_setcatn must be called before any catalog or survey query can +be made. +.ih +SEE ALSO +cqlocate, cqlocaten, cqsetcatn +.endhelp diff --git a/pkg/xtools/catquery/doc/cqsetcatn.hlp b/pkg/xtools/catquery/doc/cqsetcatn.hlp new file mode 100644 index 00000000..dac93a00 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqsetcatn.hlp @@ -0,0 +1,35 @@ +.help cqsetcatn Mar00 "Catquery Package" +.ih +NAME +cqsetcatn -- set the current catalog / survey by number +.ih +SYNOPSIS + +catno = cq_setcatn (cq, catno) + +.nf +pointer cq # the configuration file descriptor +int catno # the sequence number of the catalog / survey to be set +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls catno +The sequence number of the catalog / survey to be set. +.le +.ih +DESCRIPTION +Cq_setcatn sets the current catalog / survey by number. Cq_setcatn is an +integer function which returns the catalog / survey +record sequence number as its function value. Zero is returned if the catalog +record is not set. +.ih +NOTES +Cq_setcat or cq_setcatn must be called before any catalog or image +survey query can be made. +.ih +SEE ALSO +cqlocate, cqlocaten, cqsetcat +.endhelp diff --git a/pkg/xtools/catquery/doc/cqsqpar.hlp b/pkg/xtools/catquery/doc/cqsqpar.hlp new file mode 100644 index 00000000..57a86255 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqsqpar.hlp @@ -0,0 +1,39 @@ +.help cqsqpar Mar00 "Catquery Package" +.ih +NAME +cqsqpar -- set the value of a query parameter by name +.ih +SYNOPSIS + +parno = cq_sqpar (cq, pname, value) + +.nf +pointer cq # the configuration file descriptor +char pname # the query parameter name +char value # the query parameter value +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls pname +The name of the query parameter to be set. +.le +.ls value +The new query parameter value. +.le +.ih +DESCRIPTION +Cq_sqpar sets the value of the named query parameter. Qq_sqpar is an integer +function which returns the sequence number of the requested parameter +as its function value. Zero is returned if the requested query parameter +is not found. +.ih +NOTES +Cq_setcat or cq_setcatn must be called before a query parameter value +can be changed. +.ih +SEE ALSO +cqnqpars, cqgpar, cqgqparn, cqsqparn +.endhelp diff --git a/pkg/xtools/catquery/doc/cqsqparn.hlp b/pkg/xtools/catquery/doc/cqsqparn.hlp new file mode 100644 index 00000000..f0cc92fc --- /dev/null +++ b/pkg/xtools/catquery/doc/cqsqparn.hlp @@ -0,0 +1,39 @@ +.help cqsqparn Mar00 "Catquery Package" +.ih +NAME +cqsqparn -- set the value of a query parameter by number +.ih +SYNOPSIS + +parno = cq_sqparn (cq, parno, value) + +.nf +pointer cq # the configuration file descriptor +int parno # the sequence number of the query parameter +char value # the query parameter value +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls parno +The sequence number of the query parameter to be set. +.le +.ls value +The new query parameter value. +.le +.ih +DESCRIPTION +Cq_sqpar sets the value of the named query parameter. Qq_sqpar is an integer +function which returns the sequence number of the requested parameter +as its function value. Zero is returned if the requested query parameter +is not found. +.ih +NOTES +Cq_setcat or cq_setcatn must be called before a query parameter value +can be changed. +.ih +SEE ALSO +cqnqpars, cqgqpar, cqgparn, cqsqpar +.endhelp diff --git a/pkg/xtools/catquery/doc/cqstati.hlp b/pkg/xtools/catquery/doc/cqstati.hlp new file mode 100644 index 00000000..15fe1d9e --- /dev/null +++ b/pkg/xtools/catquery/doc/cqstati.hlp @@ -0,0 +1,61 @@ +.help cqstati Mar00 "Catquery Package" +.ih +NAME +cqstati -- get a catalog / survey integer parameter +.ih +SYNOPSIS +include <cq.h> + +ival = cq_stati (cq, parameter) + +.nf +pointer cq # the configuration file descriptor +int parameter # the parameter to be returned +.fi +.ih +ARGUMENTS +.ls cq +The configuration file descriptor. +.le +.ls parameter +The parameter to be returned. The currently supported parameters defined +in cq.h are: +.nf + CQNRECS # the number of catalog / survey file records + CQSZRECLIST # the length of the record name list in chars + CQCATNO # the current catalog number +.fi +.le +.ih +DESCRIPTION +Cq_stati returns the values of catalog / survey integer parameters. +Cq_stati is an integer function which returns the value of the requested +parameter as its function value. + +.ih +NOTES +The current catalog number CQCATNO is 0 if the current catalog has not been set +by a call to cq_setcat or cq_setcatn. + +The length of the record list CQSZRECLIST can be used to preallocate the buffer +required to fetch the text parameter CQRECLIST. + +.ih +EXAMPLES +.nf + include <cq.h> + + int cq_stati() + + .... + + sz_buf = cq_stati (cq, CQSZRECLIST) + call malloc (buf, sz_buf, TY_CHAR) + nlines = cq_statt (cq, CQRECLIST, Memc[buf], sz_buf) + + ... +.fi +.ih +SEE ALSO +cq_stats, cq_statt +.endhelp diff --git a/pkg/xtools/catquery/doc/cqstats.hlp b/pkg/xtools/catquery/doc/cqstats.hlp new file mode 100644 index 00000000..1aabc590 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqstats.hlp @@ -0,0 +1,48 @@ +.help cqstats Mar00 "Catquery Package" +.ih +NAME +cqstats -- get a catalog / survey string parameter +.ih +SYNOPSIS +include <cq.h> + +call cq_stats (cq, parameter, str, maxch) + +.nf +pointer cq # the configuration file descriptor +int parameter # the parameter to be returned +char str # the returned string parameter value +int maxch # the maximum size of the returned string parameter +.fi +.ih +ARGUMENTS +.ls cq +The catalog / survey configuration file descriptor. +.le +.ls parameter +The parameter to be returned. The string parameters defined +in cq.h are: +.nf + CQCATDB # the name of the configuration file + CQCATNAME # the name of the current catalog +.fi +.le +.ls str +Array containing returned string parameter. +.le +.ls maxch +The maximum size of the returned string parameter. +.le +.ih +DESCRIPTION +Cq_stats returns the requested catalog / survey string parameters. + +.ih +NOTES +The current catalog name CQCATNAME is "" if the current catalog has not been +set by a call to cq_setcat or cq_setcatn. + +.ih +SEE ALSO +cq_stati, cq_statt +.endhelp diff --git a/pkg/xtools/catquery/doc/cqstatt.hlp b/pkg/xtools/catquery/doc/cqstatt.hlp new file mode 100644 index 00000000..082f5757 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqstatt.hlp @@ -0,0 +1,45 @@ +.help cqstatt Mar00 "Catquery Package" +.ih +NAME +cqstatt -- get a catalog / survey text parameter +.ih +SYNOPSIS +include <cq.h> + +nlines = cq_statt (cq, parameter, text, maxch) + +.nf +pointer cq # the configuration file descriptor +int parameter # the parameter to be returned +char text # the returned text parameter value +int maxch # the maximum size of the returned text parameter +.fi +.ih +ARGUMENTS +.ls cq +The configuration catalog / survey file descriptor. +.le +.ls parameter +The parameter to be returned. The text parameters defined in cq.h are: +.nf +define CQRECLIST # the catalog configuration file record list +.fi +.le +.ls text +The returned text parameter value. Text parameters differ +from string parameters only in that they may contain embedded newline +characters. +.le +.ls maxch +The maximum size in characters of the returned text. +.le +.ih +DESCRIPTION +Cq_statt returns the requested catalog / survey text parameters. +Cq_statt is an integer function which returns the numbers of lines in the +requested parameter value as its function value. + +.ih +SEE ALSO +cq_stati, cq_stats +.endhelp diff --git a/pkg/xtools/catquery/doc/cqunmap.hlp b/pkg/xtools/catquery/doc/cqunmap.hlp new file mode 100644 index 00000000..e33128cf --- /dev/null +++ b/pkg/xtools/catquery/doc/cqunmap.hlp @@ -0,0 +1,26 @@ +.help cqunmap Mar00 "Catquery Package" +.ih +NAME +cq_unmap -- unmap the catalog / survey configuration file +.ih +SYNOPSIS +call cq_unmap (cq) + +.nf +pointer cq # the configuration file descriptor +.fi +.ih +ARGUMENTS +.ls cq +The catalog / survey configuration file descriptor. +.le +.ih +DESCRIPTION +Unmap the configuration file. +.ih +NOTES +Cq_unmap should be called when catalog / survey access is terminated. +.ih +SEE ALSO +cqmap +.endhelp diff --git a/pkg/xtools/catquery/doc/cqwinfo.hlp b/pkg/xtools/catquery/doc/cqwinfo.hlp new file mode 100644 index 00000000..9bdc7edf --- /dev/null +++ b/pkg/xtools/catquery/doc/cqwinfo.hlp @@ -0,0 +1,65 @@ +.help cqwinfo Mar00 "Catquery Package" +.ih +NAME +cqwinfo -- get the results wcs parameter description by name +.ih +SYNOPSIS + +wcsno = cq_winfo (imres, wname, wkname, max_wkname, wkvalue, max_wkvalue, + wktype, wkunits, max_wkunits) + +.nf +pointer imres # the survey results descriptor +char wname # the wcs parameter name +char wkname # the default wcs keyword name (INDEF if undefined) +int max_wkname # the maximum size of the returned keyword name +char wkvalue # the default wcs parameter value (INDEF if undefined) +int max_wkvalue # the maximum size of the parameter value +int wktype # the wcs parameter data type +char wkunits # the wcs parameter units (INDEF if undefined) +int max_wkunits # the maximum size of the returned wcs parameter units +.fi +.ih +ARGUMENTS +.ls imres +The image results descriptor. +.le +.ls wname +The name of the wcs parameter for which the description is to be returned. +.le +.ls wkname +The returned wcs parameter keyword name. Wkname is "INDEF" if undefined. +.le +.ls max_wkname +The maximum size of the returned wcs parameter keyword name. +.le +.ls wkvalue +The returned wcs parameter value. Wkvalue is "INDEF" if undefined. +.le +.ls max_wkvalue +The maximum size of the returned wcs parameter value. +.le +.ls wktype +The wcs parameter data type. The options are TY_DOUBLE, TY_REAL, TY_LONG, +TY_INT, TY_SHORT, and TY_CHAR. +.le +.ls wkunits +The returned wcs parameter units. Wkunits is "INDEF" if undefined. +.le +.ls max_wkunits +The maximum size of the returned wcs parameter units. +.le +.ih +DESCRIPTION +Cq_winfo returns the keyword name, default value, data type, and units +of the requested wcs parameter. Cq_winfo is an integer function +which returns the sequence number of the wcs parameter as its function +value. Zero is returned if the wcs parameter is not found. +.ih +NOTES +For more information about the wcs parameters and their relationship +to the image surveys configuration file type "help surveys". +.ih +SEE ALSO +cqwinfon +.endhelp diff --git a/pkg/xtools/catquery/doc/cqwinfon.hlp b/pkg/xtools/catquery/doc/cqwinfon.hlp new file mode 100644 index 00000000..04fab301 --- /dev/null +++ b/pkg/xtools/catquery/doc/cqwinfon.hlp @@ -0,0 +1,75 @@ +.help cqwinfon Mar00 "Catquery Package" +.ih +NAME +cqwinfon -- get the results wcs description by number +.ih +SYNOPSIS + +wcsno = cq_winfo (imres, wcsno, wname, max_wname, wkname, max_wkname, wkvalue, + max_wkvalue, wktype, wkunits, max_wkunits) + +.nf +pointer imres # the image results descriptor +int wcsno # the wcs parameter sequence number +char wname # the wcs parameter name +int max_wname # the maximum size of the wcs parameter name +char wkname # the default wcs keyword name (INDEF if undefined) +int max_wkname # the maximum size of the keyword name +char wkvalue # the default wcs keyword value (INDEF if undefined) +int max_wkvalue # the maximum size of the parameter value +int wktype # the wcs parameter data type +char wkunits # the wcs parameter units (INDEF if undefined) +int max_wkunits # the maximum size of the wcs parameter units +.fi +.ih +ARGUMENTS +.ls imres +The image results descriptor. +.le +.ls wcsno +The sequence number of the wcs parameter to be returned. +.le +.ls wname +The returned wcs parameter name. +.le +.ls max_wname +The maximum size of the returned wcs parameter name. +.le +.ls wkname +The returned wcs parameter keyword name. +.le +.ls max_wkname +The maximum size of the returned wcs parameter keyword name. +.le +.ls wkvalue +The returned wcs parameter value. +.le +.ls max_wkvalue +The maximum size of the returned wcs parameter value. +.le +.ls wktype +The returned wcs parameter type. The options are TY_DOUBLE, TY_REAL, TY_LONG, +TY_INT, TY_SHORT, and TY_CHAR. +.le +.ls wkunits +The returned wcs parameter units. +.le +.ls max_wkunits +The maximum size of the returned wcs parameter units. +.le +.ih +DESCRIPTION +Cq_winfon returns the parameter name, keyword name, default value, data type, +and units of the requested wcs parameter. Cq_winfon is an integer function +which returns the sequence number of the wcs parameter as its function +value. Zero is returned if the wcs parameter is not found. + +.ih +NOTES +For more information about the wcs parameters and their relationship +to the image surveys configuration file type "help surveys". + +.ih +SEE ALSO +cqwinfo +.endhelp diff --git a/pkg/xtools/catquery/doc/surveys.hlp b/pkg/xtools/catquery/doc/surveys.hlp new file mode 100644 index 00000000..bfc50e69 --- /dev/null +++ b/pkg/xtools/catquery/doc/surveys.hlp @@ -0,0 +1,197 @@ +.help surveys Mar00 catquery +.ih +NAME +surveys -- describe the image survey configuration file +.ih +USAGE +help surveys +.ih +IMAGE SURVEYS + +An image survey contains image data for a large region of the sky from which +image data for small regions of the sky can be extracted. +Image surveys may be installed locally or accessed remotely. Each +supported survey must have a record in the image survey configuration file, +which define the image survey network address, the image survey query format, +and the image survey query output format. + +.ih +THE IMAGE SURVEY CONFIGURATION FILE + +A record in the image survey configuration file specifies the network address, +the query format, and the output image format for each supported image server. +Each image server is accessed via a record name of the form +"survey@server", e.g. "dss2@cadc". Adding support for a new image survey +server or responding to changes in the behavior of an existing image survey +server requires either adding a new record to the configuration file or +changing an existing record. No modification to the survey access +code should be required. + +The server network address tells the image survey access code where and how to +connect to the network. Each network address has the syntax +"domain:port:address:flags" e.g. "inet:80:www.noao.edu:text". + +The query format specifies the form of the query server string, and the +names, default values, units, and format of the query parameters. A set of +standard query parameter names are reserved for accessing image surveys +including "ra", "dec", "radius", "width", "xwidth", and "ywidth". + +The server output format specifies the format of the expected server output: +including the image type, the world coordinate system type, and the +standard keyword set. At present the only supported image type is FITS, +the only supported world coordinate system types are FITS and DSS, +and the standard keyword set includes keyword that are required or +useful for astrometric analysis tasks. + +.ih +SAMPLE IMAGE SURVEY RECORD + +The following example illustrates the main features of a typical image survey +configuration file record. + +.nf +begin dss1@cadc +address inet:80:cadcwww.hia.nrc.ca:binary +query GET /cadcbin/dss-server?ra=%-s&dec=%-s&mime-type=application/x-fits&x=%-s +&y=%-s HTTP/1.0\n\n +nquery 5 + ra 00:00:00.00 hours %0.2h + dec +00:00:00.0 degrees %0.1h + xwidth 10.0 minutes %0.1f + ywidth 10.0 minutes %0.1f + qsystem J2000.0 INDEF %s +type fits +wcs dss +nwcs 10 + wxref INDEF INDEF d pixels + wyref INDEF INDEF d pixels + wxmag INDEF 1.701 d arcsec/pixel + wymag INDEF 1.701 d arcsec/pixel + wxrot INDEF 180.0 d degrees + wyrot INDEF 0.0 d degrees + wraref OBJCTRA INDEF d hms + wdecref OBJCTDEC INDEF d dms + wproj INDEF tan c INDEF + wsystem INDEF J2000 c INDEF +nkeys 13 + observat INDEF Palomar c INDEF + esitelng INDEF +116:51:46.80 d degrees + esitelat INDEF +33:21:21.6 d degrees + esitealt INDEF 1706 r meters + esitetz INDEF 8 r INDEF + emjdobs INDEF INDEF d INDEF + edatamin INDEF INDEF r ADU + edatamax INDEF INDEF r ADU + gain INDEF INDEF r e-/ADU + erdnoise INDEF INDEF r e- + ewavlen INDEF INDEF r angstroms + etemp INDEF INDEF r degrees + epress INDEF INDEF r mbars +.fi + +The beginning of a new image survey record is indicated by a line +of the form \fI"begin surveyname"\fR where surveyname is a unique name of the +form \fI"survey@server"\fR. Any number of unique names can access the same +image survey. If more than one record with the same name exists in the +configuration file the last record is the one read. Multiple entries for +the same catalog can be used to define a different query format or different +output type. For example if an image server supports more than one output +formats then two records with two different queries can be defined, +one which outputs one format, and another which outputs a different one. + +The \fIaddress\fR, \fIquery\fR and \fInquery\fR keywords are required, and +define the network address, query command format and query parameters for +the image survey. + +The \fIaddress\fR keyword "domain", "port", and "flags" fields are almost +always "inet", "80", and "binary" respectively for image surveys, so +the only field that has to be defined is the address field +":cadcwww.hia.nrc.ca" in this case. + +The \fIquery\fR keyword defines the query command whose form is server +dependent. The query parameter values are encoded via the %-s formatting +strings. The calling program must encode the user query parameter values +into a set a strings which then replace the -%s format statement in the +query string. + +The number of query parameters is defined by the \fInquery\fR parameter. The +number of query parameters must be greater than or equal to the number of "-%s" +strings in the query keyword value. The name, default value, units, +and format of each query parameter are listed below the nquery keyword +one query parameter description per line. The query parameters should be +defined in the configuration file in the same order that they appear +in the query keyword value. Alert readers will notice that in the example above +the number of query parameters is 5 but there are only 4 "%-s" strings +in the query keyword value. In this example the qsystem query parameter which +defined the coordinate system of the ra and dec query parameter values is +fixed at J2000. For some servers this parameter may be a true query parameter, +i.e. the server may accept coordinates in B1950 or J2000 or some other +coordinate system. + +For "astrometric" image surveys the reserved query parameter names "ra", "dec", +and "qsystem" should be used to define the extraction region center and its +coordinate system, and one or more of "radius", "width", "xwidth", and +"ywidth" should be used to define the extraction region size. The units +of "ra" should be "hours", "degrees", or "radians", the units of dec +should be "degrees" or "radians", and units of the size query parameter +should be "degrees" or "minutes". The qsystem parameter value may be +any one of the supported celestial coordinate systems. The most common +qsystem values are "icrs", "J2000", or "B1950". The query parameter +formats are used to convert numerical values supplied by the calling +program to string values that can be passed to the query string. +It should be emphasized that the reserved query parameter names and units +are conventions that are adopted to simplify writing the configuration +file and astrometric applications. They are not part of the image survey +access API itself. + +The \fItype\fR keyword defines the format of the output image data. At +present only FITS data is supported. + +The \fIwcs\fR keyword defines the wcs status of the image. The options +are "fits" for an image which contains a valid FITS wcs, "dss" for an image +which contains a valid DSS wcs, and "none" for an image contains no +standard wcs information. + +The \fInwcs\fR keyword defines the number of following wcs parameters. Each +wcs parameter definition consists of a standard keyword name, the actual +keyword name or INDEF if no keyword exists, the default keyword value or +INDEF is there is no default value, the data type which must be one of +d(double), r(real), (i)integer, or c(character), and the units which may +be INDEF if they are undefined. + +The reserved standard wcs keyword names \fIwxref\fR, +\fIwyref\fR, \fIwxmag\fR, \fIwymag\fR, \fIwxref\fR, \fIwyref\fR, \fIwraref\fR, +\fIwdecref\fR, \fIwproj\fR, and \fIwsystem\fR, should be used to define the +pixel reference coordinates, the pixel scale in "/ pixel, the coordinate +system rotation and skew in degrees, the reference coordinates in some celestial +coordinate system, the image projection, and the celestial coordinate system. +The units of wraref may be "hours", "degrees" or "radians" and the units +of wdecref may be "hours" and "degrees". At present the units for the +remaining wcs keywords should be regarded as fixed. It should be emphasized +that the reserved standard wcs parameter names and units are conventions that +are adopted to simplify writing the configuration file and astrometric image +applications. They are not part of the image survey access API itself. + +The \fInkeys\fR keyword defines the number of following standard keyword +parameters. Each parameter definition consists of a standard keyword name, +the actual keyword name or INDEF is no keyword exists, the default value +or INDEF is there is no default value, the data type which must be one of +d(double), r(real), (i)integer, or c(character), and the parameter units +which may be INDEF if they are undefined. + +The reserved standard keyword names \fIobservat\fR, +\fIesitelng\fR, \fIesitelat\fR, \fIesitelat\fR, and \fIesitetz\fR should be +used to define the site, \fIemjdobs\fR, \fIewavelen\fR, \fIetemp\fR, +and \fIepress\fR to define the time and physical conditions of the observation, + and \fIedatamin\fR, \fIedatamax\fR, \fIegain\fR, and \fIerdnoise\fR +to define the detector parameters. At present the units of all these +parameters should be regarded as fixed. +It should be emphasized that the reserved standard header parameter names and +units are conventions that are adopted to simplify writing the configuration +file and astrometric image applications. They are not part of the image survey +access API itself. + +.ih +SEE ALSO +ccsystems, catalogs +.endhelp diff --git a/pkg/xtools/catquery/mkpkg b/pkg/xtools/catquery/mkpkg new file mode 100644 index 00000000..91f0b557 --- /dev/null +++ b/pkg/xtools/catquery/mkpkg @@ -0,0 +1,32 @@ +# Catalog and survey access tools subdirectory + +$checkout libxtools.a lib$ +$update libxtools.a +$checkin libxtools.a lib$ +$exit + +libxtools.a: + cqmap.x <ctype.h> "cqdef.h" + cqstat.x "cqdef.h" "cq.h" + cqlocate.x "cqdef.h" + + cqsetcat.x "cqdef.h" "cq.h" + cqnqpars.x "cqdef.h" + cqgqpars.x "cqdef.h" + cqsqpars.x "cqdef.h" "cq.h" + + cqquery.x <fset.h> "cqdef.h" "cq.h" + cqrstat.x "cqdef.h" "cq.h" + cqrinfo.x "cqdef.h" "cq.h" + cqgrecords.x "cqdef.h" "cq.h" + cqgfields.x <ctype.h> "cqdef.h" "cq.h" + + cqimquery.x <fset.h> "cqdef.h" "cq.h" + cqistat.x "cqdef.h" "cq.h" + cqiminfo.x "cqdef.h" "cq.h" + + cqget.x "cqdef.h" "cq.h" + cqdb.x <ctype.h> "cqdef.h" "cq.h" + cqwrdstr.x + cqdtype.x + ; diff --git a/pkg/xtools/center1d.h b/pkg/xtools/center1d.h new file mode 100644 index 00000000..c2d4972d --- /dev/null +++ b/pkg/xtools/center1d.h @@ -0,0 +1,6 @@ +# Type of features for one dimensional centering. + +define EMISSION 1 # Emission feature +define ABSORPTION 2 # Absorption feature + +define FTYPES "|emission|absorption|" # Types for strdic and clgwrd. diff --git a/pkg/xtools/center1d.x b/pkg/xtools/center1d.x new file mode 100644 index 00000000..33a6ec3d --- /dev/null +++ b/pkg/xtools/center1d.x @@ -0,0 +1,272 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/iminterp.h> +include <pkg/center1d.h> + +define MIN_WIDTH 3. # Minimum centering width +define EPSILON 0.001 # Accuracy of centering +define EPSILON1 0.005 # Tolerance for convergence check +define ITERATIONS 100 # Maximum number of iterations +define MAX_DXCHECK 3 # Look back for failed convergence +define INTERPTYPE II_SPLINE3 # Image interpolation type + + +# CENTER1D -- Locate the center of a one dimensional feature. +# A value of INDEF is returned in the centering fails for any reason. +# This procedure just sets up the data and adjusts for emission or +# absorption features. The actual centering is done by C1D_CENTER. +# If twidth <= 1 return the nearest minima or maxima. + +real procedure center1d (x, data, npts, width, type, radius, threshold) + +real x # Initial guess +int npts # Number of data points +real data[npts] # Data points +real width # Feature width +int type # Feature type +real radius # Centering radius +real threshold # Minimum range in feature + +real xc # Center + +int x1, x2, nx +real a, b, rad, wid +pointer sp, data1 + +real c1d_center() + +begin + + # Check starting value. + if (IS_INDEF(x) || (x < 1) || (x > npts)) + return (INDEF) + + # Set parameters. The minimum in the error radius + # is for defining the data window. The user error radius is used to + # check for an error in the derived center at the end of the centering. + + call c1d_params (INDEFI, INDEFR) + wid = max (width, MIN_WIDTH) + rad = max (2., radius) + + # Determine the pixel value range around the initial center, including + # the width and error radius buffer. Check for a minimum range. + + x1 = max (1., x - wid / 2 - rad - wid) + x2 = min (real (npts), x + wid / 2 + rad + wid + 1) + nx = x2 - x1 + 1 + call alimr (data[x1], nx, a, b) + if (b - a < threshold) + return (INDEF) + + # Allocate memory for the continuum subtracted data vector. The X + # range is just large enough to include the error radius and the + # half width. + + x1 = max (1., x - wid / 2 - rad) + x2 = min (real (npts), x + wid / 2 + rad + 1) + nx = x2 - x1 + 1 + + call smark (sp) + call salloc (data1, nx, TY_REAL) + call amovr (data[x1], Memr[data1], nx) + + # Make the centering data positive, subtract the continuum, and + # apply a threshold to eliminate noise spikes. + + switch (type) { + case EMISSION: + a = min (0., a) + call asubkr (data[x1], a + threshold, Memr[data1], nx) + call amaxkr (Memr[data1], 0., Memr[data1], nx) + case ABSORPTION: + call anegr (data[x1], Memr[data1], nx) + call asubkr (Memr[data1], threshold - b, Memr[data1], nx) + call amaxkr (Memr[data1], 0., Memr[data1], nx) + default: + call error (0, "Unknown feature type") + } + + # Determine the center. + xc = c1d_center (x - x1 + 1, Memr[data1], nx, width) + + # Check user centering error radius. + if (!IS_INDEF(xc)) { + xc = xc + x1 - 1 + if (abs (x - xc) > radius) + xc = INDEF + } + + # Free memory and return the center position. + call sfree (sp) + return (xc) +end + + +# C1D_PARAMS -- Set parameters. + +procedure c1d_params (interp, eps) + +int interp # Interpolation type +real eps # Accuracy of centering + +int first +data first /YES/ + +int interptype +real epsilon +common /c1d_common/ interptype, epsilon + +begin + if (!IS_INDEFI(interp)) + interptype = interp + else if (first == YES) + interptype = INTERPTYPE + + if (!IS_INDEFR(eps)) + epsilon = eps + else if (first == YES) + epsilon = EPSILON + + first = NO +end + + +# C1D_CENTER -- One dimensional centering algorithm. +# If the width is <= 1. return the nearest local maximum. + +real procedure c1d_center (x, data, npts, width) + +real x # Starting guess +int npts # Number of points in data vector +real data[npts] # Data vector +real width # Centering width + +int i, j, iteration, dxcheck +real xc, wid, hwidth, dx, dxabs, dxlast +real a, b, sum1, sum2, intgrl1, intgrl2 +pointer asi1, asi2, sp, data1 + +real asigrl() + +int interptype +real epsilon +common /c1d_common/ interptype, epsilon + +define done_ 99 + +begin + # Find the nearest local maxima as the starting point. + # This is required because the threshold limit may have set + # large regions of the data to zero and without a gradient + # the centering will fail. + + for (i=x+.5; (i<npts) && (data[i]<=data[i+1]); i=i+1) + ; + for (; (i>1) && (data[i]<=data[i-1]); i=i-1) + ; + for (j=x+.5; (j>1) && (data[j]<=data[j-1]); j=j-1) + ; + for (; (j<npts) && (data[j]<=data[j+1]); j=j+1) + ; + + if (abs(i-x) < abs(x-j)) + xc = i + else + xc = j + + if (width <= 1.) + return (xc) + + wid = max (width, MIN_WIDTH) + + # Check data range. + hwidth = wid / 2 + if ((xc - hwidth < 1) || (xc + hwidth > npts)) + return (INDEF) + + # Set interpolation functions. + call asiinit (asi1, interptype) + call asiinit (asi2, interptype) + call asifit (asi1, data, npts) + + # Allocate, compute, and interpolate the x*y values. + call smark (sp) + call salloc (data1, npts, TY_REAL) + do i = 1, npts + Memr[data1+i-1] = data[i] * i + call asifit (asi2, Memr[data1], npts) + call sfree (sp) + + # Iterate to find center. This loop exits when 1) the maximum + # number of iterations is reached, 2) the delta is less than + # the required accuracy (criterion for finding a center), 3) + # there is a problem in the computation, 4) successive steps + # continue to exceed the minimum delta. + + dxlast = npts + do iteration = 1, ITERATIONS { + # Ramp centering function. + # a = xc - hwidth + # b = xc + hwidth + # intgrl1 = asigrl (asi1, a, b) + # intgrl2 = asigrl (asi2, a, b) + # sum1 = intgrl2 - xc * intgrl1 + # sum2 = intgrl1 + + # Triangle centering function. + a = xc - hwidth + b = xc - hwidth / 2 + intgrl1 = asigrl (asi1, a, b) + intgrl2 = asigrl (asi2, a, b) + sum1 = (xc - hwidth) * intgrl1 - intgrl2 + sum2 = -intgrl1 + a = b + b = xc + hwidth / 2 + intgrl1 = asigrl (asi1, a, b) + intgrl2 = asigrl (asi2, a, b) + sum1 = sum1 - xc * intgrl1 + intgrl2 + sum2 = sum2 + intgrl1 + a = b + b = xc + hwidth + intgrl1 = asigrl (asi1, a, b) + intgrl2 = asigrl (asi2, a, b) + sum1 = sum1 + (xc + hwidth) * intgrl1 - intgrl2 + sum2 = sum2 - intgrl1 + + # Return no center if sum2 is zero. + if (sum2 == 0.) + break + + # Limit dx change in one iteration to 1 pixel. + dx = sum1 / abs (sum2) + dxabs = abs (dx) + xc = xc + max (-1., min (1., dx)) + + # Check data range. Return no center if at edge of data. + if ((xc - hwidth < 1) || (xc + hwidth > npts)) + break + + # Convergence tests. + if (dxabs < epsilon) + goto done_ + if (dxabs > dxlast + EPSILON1) { + dxcheck = dxcheck + 1 + if (dxcheck > MAX_DXCHECK) + break + } else if (dxabs > dxlast - EPSILON1) { + xc = xc - max (-1., min (1., dx)) / 2 + dxcheck = 0 + } else { + dxcheck = 0 + dxlast = dxabs + } + } + + # If we get here then no center was found. + xc = INDEF + +done_ call asifree (asi1) + call asifree (asi2) + return (xc) +end diff --git a/pkg/xtools/clgcurfit.x b/pkg/xtools/clgcurfit.x new file mode 100644 index 00000000..89818c1a --- /dev/null +++ b/pkg/xtools/clgcurfit.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +# CLGCURFIT -- Get the curve type and order for the curfit package. +# +# Prompt1 is issued for the curve type. The curve type is entered +# as a minimum abbreviation string with clgwrd. The allowed strings +# are legendre, chebyshev, and spline3. Prompt2 is issued to get +# the order. + +procedure clgcurfit (prompt1, prompt2, curve_type, order) + +char prompt1[ARB], prompt2[ARB] +int curve_type +int order + +char str[SZ_LINE] +int i, curtypes[3], clgwrd(), clgeti() +errchk clgwrd + +data curtypes/LEGENDRE, CHEBYSHEV, SPLINE3/ + +begin + + i = clgwrd (prompt1, str, SZ_LINE, ",legendre,chebyshev,spline3,") + curve_type = curtypes[i] + order = clgeti (prompt2) +end diff --git a/pkg/xtools/clginterp.x b/pkg/xtools/clginterp.x new file mode 100644 index 00000000..c65d69ca --- /dev/null +++ b/pkg/xtools/clginterp.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/iminterp.h> + +# CLGINTERP -- Select an interpolator from a CL input string. The procedure +# is coded to be protected from changes in the values of the interpolator +# types in interpdef.h. + +int procedure clginterp (param) + +char param[ARB] # CL parameter prompt string +int index, iicodes[5] +pointer sp, word +int clgwrd() +errchk clgwrd +data iicodes /II_NEAREST, II_LINEAR, II_POLY3, II_POLY5, II_SPLINE3/ + +begin + call smark (sp) + call salloc (word, SZ_FNAME, TY_CHAR) + + index = max (1, min (5, clgwrd (param, Memc[word], SZ_FNAME, + "|nearest|linear|poly3|poly5|spline3|"))) + + call sfree (sp) + return (iicodes[index]) +end diff --git a/pkg/xtools/clgsec.x b/pkg/xtools/clgsec.x new file mode 100644 index 00000000..2c3149d8 --- /dev/null +++ b/pkg/xtools/clgsec.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <ctype.h> +include <imhdr.h> + +define FIRST 1 +define LAST MAX_LONG +define STEP 1 + +# CLGSEC -- Get an image section and decode it. +# +# A section string may be either a null string or bracketed by []. +# The arrays x1, x2, and step are initialized to FIRST, LAST, and STEP. +# The number of subscripts decoded is returned in nsubscripts. +# This routine uses the same decode routine as IMIO. + +procedure clgsec (prompt, section, x1, x2, step, nsubscripts) + +char prompt[ARB] +char section[ARB] +long x1[IM_MAXDIM] +long x2[IM_MAXDIM] +long step[IM_MAXDIM] +int nsubscripts + +int i, ip + +begin + # Get section string. + call clgstr (prompt, section ,SZ_LINE) + + # Set default values. + nsubscripts = 0 + call amovkl (long (FIRST), x1, IM_MAXDIM) + call amovkl (long (LAST), x2, IM_MAXDIM) + call amovkl (long (STEP), step, IM_MAXDIM) + + # Skip leading whitespace. + ip = 1 + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Check for absent section. + if (section[ip] == EOS) + return + + # Check for start of section string. + if (section[ip] != '[') + call error (0, "Invalid image section") + + # Decode section. + ip = ip + 1 + for (i=1; i <= IM_MAXDIM && section[ip] != ']'; i=i+1) + call im_decode_subscript (section, ip, x1[i], x2[i], step[i]) + nsubscripts = i - 1 +end diff --git a/pkg/xtools/cogetr.h b/pkg/xtools/cogetr.h new file mode 100644 index 00000000..3e0f9762 --- /dev/null +++ b/pkg/xtools/cogetr.h @@ -0,0 +1,16 @@ +# Definitions for the image column procedure. + +define LEN_CO 10 + +define CO_IM Memi[$1] # IMIO pointer +define CO_MAXBUF Memi[$1+1] # Maximum buffer size +define CO_DATA Memi[$1+2] # Column data pointer +define CO_BUF Memi[$1+3] # Buffer +define CO_NCOLS Memi[$1+4] # Number of columns in buffer +define CO_NLINES Memi[$1+5] # Number of lines in buffer +define CO_COL1 Memi[$1+6] # First column of buffer +define CO_COL2 Memi[$1+7] # Last column of buffer +define CO_LINE1 Memi[$1+8] # First line of data +define CO_LINE2 Memi[$1+9] # Last line of data + +define EXTRA 2 # Number of extra lines in buffer diff --git a/pkg/xtools/cogetr.x b/pkg/xtools/cogetr.x new file mode 100644 index 00000000..823d54f3 --- /dev/null +++ b/pkg/xtools/cogetr.x @@ -0,0 +1,162 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "cogetr.h" + +# COGETR -- Get a real column vector from a 2D image. +# +# This procedure is designed to be efficient when: +# 1. The columns are accessed sequentially. +# 2. The number of lines does not change. +# 3. The first and last lines change slowly with column. +# One such case is when the entire column of an image is required. Then +# the first and last lines do not change at all. Another type of use +# occurs when dealing with features which are aligned nearly +# with the image lines. For example objects in a long slit spectrum or +# Echelle orders. +# +# As the columns are accessed sequentially new lines are added to a +# scrolled buffer only when the first and last lines fall outside the +# buffer. If the buffer size is insufficient to hold the all the columns +# then the buffer is set to contain a block of columns. When the desired +# column is outside the block of columns then a new block is read. +# The buffer is created and initialized when the buffer pointer +# is null or when the number of lines requested is changed. Both the +# buffer and the column data pointer are allocated in this procedure. +# The user must free the buffers with the procedure COUNMAP. + +pointer procedure cogetr (co, col, line1, line2) + +pointer co # COIO pointer +int col # Column +int line1 # First image line of column vector +int line2 # Last image line of column vector + +int ncols, nlines, lastc1, lastl1, lastl2 +int i, imlen1, imlen2, col1, nc +pointer im, coldata, buffer, buf, data + +pointer imgl2r() + +begin + # Dereference the structure elements to improve the readability of + # the code and reduce the Mem index arithmetic. + + im = CO_IM(co) + coldata = CO_DATA(co) + buffer = CO_BUF(co) + ncols = CO_NCOLS(co) + nlines = CO_NLINES(co) + lastc1 = CO_COL1(co) + lastl1 = CO_LINE1(co) + lastl2 = CO_LINE2(co) + imlen1 = IM_LEN (im, 1) + imlen2 = IM_LEN (im, 2) + + # If memory has not been allocated then allocate it. + # If the number of lines changes reallocate the buffer and + # initialize lastc1 to zero to force a full buffer read. + + i = min (imlen2, (line2 - line1 + 1) + 2 * EXTRA) + + if ((buffer == NULL) || (nlines != i)) { + nlines = i + ncols = min (imlen1, CO_MAXBUF(co) / nlines) + lastc1 = 0 + + call mfree (coldata, TY_REAL) + call mfree (buffer, TY_REAL) + call malloc (coldata, line2 - line1 + 1, TY_REAL) + call malloc (buffer, ncols * nlines, TY_REAL) + + CO_DATA(co) = coldata + CO_BUF(co) = buffer + CO_NCOLS(co) = ncols + CO_NLINES(co) = nlines + } + + # Determine the starting column and the number of columns per line. + + col1 = ((col - 1) / ncols) * ncols + 1 + nc = min (ncols, imlen1 - col1 + 1) + + # If there is no overlap with the last buffer then read all the + # requested lines. Otherwise read only the image lines with are + # different from the last buffer. + + if ((col1 != lastc1) || (line1 > lastl2) || (line2 < lastl1)) { + lastc1 = col1 + lastl1 = max (1, line1 - EXTRA) + lastl2 = min (imlen2, line2 + EXTRA) + do i = lastl1, lastl2 { + buf = buffer + mod (i, nlines) * ncols + call amovr (Memr[imgl2r(im, i)+col1-1], Memr[buf], nc) + } + CO_COL1(co) = lastc1 + CO_LINE1(co) = lastl1 + CO_LINE2(co) = lastl2 + + } else if (line1 < lastl1) { + do i = max (1, line1 - EXTRA), min (imlen2, lastl1 - 1) { + buf = buffer + mod (i, nlines) * ncols + call amovr (Memr[imgl2r(im, i)+col1-1], Memr[buf], nc) + } + lastl1 = max (1, line1 - EXTRA) + lastl2 = min (imlen2, line2 + EXTRA) + CO_LINE1(co) = lastl1 + CO_LINE2(co) = lastl2 + + } else if (line2 > lastl2) { + do i = max (1, lastl2 + 1), min (imlen2, line2 + EXTRA) { + buf = buffer + mod (i, nlines) * ncols + call amovr (Memr[imgl2r(im, i)+col1-1], Memr[buf], nc) + } + lastl1 = max (1, line1 - EXTRA) + lastl2 = min (imlen2, line2 + EXTRA) + CO_LINE1(co) = lastl1 + CO_LINE2(co) = lastl2 + } + + # Set the column data vector. + + data = coldata + do i = line1, line2 { + buf = buffer + mod (i, nlines) * ncols + Memr[data] = Memr[buf+col-col1] + data = data + 1 + } + + return (coldata) +end + + +# COMAP -- Map the column access + +pointer procedure comap (im, maxbuf) + +pointer im # IMIO pointer +int maxbuf # Maximum buffer size +pointer co # Returned pointer + +begin + call malloc (co, LEN_CO, TY_LONG) + CO_IM(co) = im + CO_MAXBUF(co) = maxbuf + CO_DATA(co) = NULL + CO_BUF(co) = NULL + + return (co) +end + + +# COUMAP -- Unmap the column access + +procedure counmap (co) + +pointer co # Pointer to buffer structure + +begin + call mfree (CO_DATA(co), TY_REAL) + call mfree (CO_BUF(co), TY_REAL) + call mfree (co, TY_LONG) +end diff --git a/pkg/xtools/doc/Notes b/pkg/xtools/doc/Notes new file mode 100644 index 00000000..4fd91876 --- /dev/null +++ b/pkg/xtools/doc/Notes @@ -0,0 +1,42 @@ +------ +# GETDATATYPE -- Convert a character to an IRAF data type (one of TY_*) +# Recognized character codes "bcusilrdx" + +int procedure getdatatype (c) + +char c +______ +DECODE_RANGES: See help text in source code or ranges.doc. +______ +GET_NEXT_NUMBER: See help text in source code or ranges.doc. +______ +IS_IN_RANGE: See help text in source code or ranges.doc. +______ +# EXTREMA -- Find the extrema in a set of x and y data points + +Help text is in the source code +______ +# PEAKS -- Find the peaks in a set of x and y data points + +Help text is in the source code +______ +# CLGSEC -- Get an image section and decode it. +# +# A section string may be either a null string or bracketed by []. +# The arrays x1, x2, and step are initialized to FIRST, LAST, and STEP. +# The number of subscripts decoded is returned in nsubscripts. +# This routine uses the same decode routine as IMIO. + + +define FIRST 1 +define LAST MAX_LONG +define STEP 1 + +procedure clgsec (prompt, section, x1, x2, step, nsubscripts) + +char prompt[ARB] +char section[ARB] +long x1[IM_MAXDIM] +long x2[IM_MAXDIM] +long step[IM_MAXDIM] +int nsubscripts diff --git a/pkg/xtools/doc/center1d.hlp b/pkg/xtools/doc/center1d.hlp new file mode 100644 index 00000000..742fa7cb --- /dev/null +++ b/pkg/xtools/doc/center1d.hlp @@ -0,0 +1,147 @@ +.help center1d May93 xtools +.ih +NAME +center1d -- One dimensional centering +.ih +SYNOPSIS +.nf +center = center1d (initial, data, npts, width, type, radius, threshold) + +real initial # Initial guess +real data[npts] # Data points +int npts # Number of data points +real width # Feature width +int type # Feature type +real radius # Centering radius +real threshold # Detection threshold +.fi +.ih +ARGUMENTS +.ls initial +Initial guess for the center of the feature. +.le +.ls data[npts] +Pixel data vector. +.le +.ls npts +Number of points in the data vector. +.le +.ls width +Width used to define the convolution function. If the width is 1 or less +then the nearest minimum or maximum is returned. If the width is greater +than 1 then a minimum with of 3 is used in the algorithm. +.le +.ls type +Type of feature. The feature types are defined in the file <xtools/center1d.h>. +Currently the types are emission and absorption features. +.le +.ls radius +Centering radius or error limit about the initial guess. +.le +.ls threshold +Minimum difference between the maximum and minimum pixel value in the +region around the initial guess allowed for detecting a feature. For +data which is all positive and the type is emission then the +threshold is also used as an absolute cutoff. +.le +.ih +DESCRIPTION +If the width is 1 or less then the nearest minimum or maximum is found. +The centering radius is still applied as is the threshold. If the width +is greater than 1 then a minimum width of 3 is used in the algorithm. + +The one dimensional position of a feature is determined by solving the equation + + (1) integral {(I-I0) f(X-XC) dX} = 0 + +where I is the intensity at position X, I0 is the continuum intensity, X is the +pixel coordinate, and XC is the desired feature position. Figure 1 shows +the range of pixels used in determining the continuum intensity, the feature +threshold, and solving the equation. + +.ks +.nf + Figure 1: Data Feature Vector + +-----------------------------------------------------------+ + -| * | + S| * * | + | * * | + t| * ** | + | * * | + r| * * | + | * * | + e| * * | + | * * | + n| * * * *| + | * * * * * | + t| * * | + | * * | + h| * | + -| * | + +---------+-----------------+---------------------+---------+ + -B -A 0 A B + + X-XC + + A = radius + 0.5 width B = radius + 1.5 width +.fi +.ke + +The range -A to A is used to determine the continuum intensity and +the strength of the feature. For absorption features the continuum +intensity is the maximum point in this range while for emission +features the continuum is set to zero. Admittedly these are not real +measures of the continuum but they contain the fewest assumptions +and are tolerant of nearby contaminating features. The feature strength +is the difference between the maximum and minimum values. If the feature +strength is less than the specified detection threshold then a value of +INDEF is returned for the feature position. + +.ks +The range -B to B includes the range of allowed feature positions plus the +half-width of the feature. This range is used in solving equation (1). +The convolution function f(X-XC) is a sawtooth as shown in figure 2. +For absorption features the negative of this function is used. + +.nf + Figure 2: f(X-XC) + +-------------------+-------------------+ + | | * | + | | * * | + | | * * | + 0 +-*-*-*-*-----------*-----------*-*-*-*-+ + | * * | | + | * * | | + | * | | + +-------+-----------+-----------+-------+ + -width/2 0 width/2 + + X-XC +.fi +.ke + +The two figures graphically define the parameter \fIwidth\fR. Generally +it should be set to a value near the actual width of the emission or absorption +feature. If the width is too wide then the center will be affected by blending +from nearby lines while if it is too narrow the accuracy of the centering is +decreased. The parameter \fBradius\fR determines how far from the initial +estimate for XC the interactive solution of (1) may go. +Equation (1) is solved iteratively starting with the initial position. +When successive positions agree within 0.1% of a pixel the position is +returned. If the position wanders further than \fIradius\fR from the +initial guess or outside of the data vector then the procedure returns +the value INDEF. If more than 100 iterations are required or the corrections +per iteration exceed the minimum correction reached after 3 further iterations +then the solution has failed to converge and INDEF is returned. Note that +this latter condition may occur if the width is too small in a flat topped +profile. + +This task uses the one dimensional image interpolation package \fBiminterp\fR +in solving equation (1). +.ih +BUGS +Though the algorithm does not fail if the width is made very small the +results become unreliable. Therefore a silent limit of 3 is imposed +by the algorithm. If there is ever a need to allow smaller widths +then the procedure can be changed and the applications relinked. +.endhelp diff --git a/pkg/xtools/doc/cogetr.hlp b/pkg/xtools/doc/cogetr.hlp new file mode 100644 index 00000000..416935c9 --- /dev/null +++ b/pkg/xtools/doc/cogetr.hlp @@ -0,0 +1,88 @@ +.help cogetr.hlp Feb86 xtools +.ih +NAME +.nf +comap -- Initialize buffered image column access +cogetr -- Get buffered image columns from 2D image +counmap -- Free memory used in image column access +.fi +.ih +SYNOPSIS +.nf +pointer im # IMIO pointer +pointer co # COGETR pointer +int maxbuf # Maximum buffer size +int col # Column +int line1 # First image line of column vector +int line2 # Last image line of column vector +pointer buf # Returned pointer + +pointer immap() # Map the image +pointer comap() # Map the column access +pointer cogetr() # Get columns + + im = immap (image, mode, 0) + co = comap (im, maxbuf) + buf = cogetr (co, col, line1, line2) + call counmap (co) +.fi +.ih +DESCRIPTION +A pointer to a real image column vector between the limits \fIline1\fR +and \fIline2\fR is returned. Internally the image data is buffered as +a scrolled two dimensional section to minimize the number of image +reads. This interface is designed to be efficient when: + +.nf +(1) The columns are accessed sequentially. +(2) The number of lines does not change. +(3) The first and last lines change slowly with the column accessed. +.fi + +The column access interface is initialized with the procedure +\fBcomap\fR. At this time the maximum size of the internal buffer is +set. The buffer should be reasonably large. + +When the first column +access is made with \fBcogetr\fR a buffer is created containing the +number of lines requested and as many columns as will fit within the +maximum buffer size. When the number of lines is small then the number +of columns buffered will be large (as large as the image if possible). +When the number of lines is large then the columns may be buffered in +blocks across the image. A pointer to the real column vector requested is +returned. Subsequent calls to \fBcogetr\fR will return columns from the +buffer without reading the image until a new buffer is required +provided that the line limits do not change. If the columns are +accessed sequentially (usually from the first column to +the last column) then the image will be accessed a minimum number of +times consistent with the buffer size. + +One type of application accesses entire columns from the image +so that the first and last lines do not change. Another type allows +the line limits to change in such a way that the total number of lines +does not change and the changes are only a few lines between calls. +In this case only the new lines are added to the scrolled buffer +without the entire buffer needing to be filled. +Applications of this type occur when following a feature across an +image such as objects in long slit spectra or echelle orders. + +The buffer is created and initialized when the buffer pointer +is null or when the number of lines requested is changed. Both the +buffer and the column data pointer are allocated by \fBcogetr\fR. +The user must free the buffers with the procedure \fBcounmap\fR. +.ih +RETURNED VALUES +\fBComap\fR returns a pointer to a structure internal to the interface. +\fBCogetr\fR returns a pointer to a real vector containing the requested +image column. +.ih +TIMINGS +When used in applications requiring sequential column access with +the line limits changing slowly or not at all this interface provides +access nearly as efficiently as accessing lines. The actual difference +with the same application applied to lines depends on the number of +buffer reads required (i.e. on the size of the image). +.ih +SEE ALSO +xtsums +.endhelp diff --git a/pkg/xtools/doc/extrema.hlp b/pkg/xtools/doc/extrema.hlp new file mode 100644 index 00000000..cea82502 --- /dev/null +++ b/pkg/xtools/doc/extrema.hlp @@ -0,0 +1,27 @@ +.help extrema Dec83 xtools +.ih +NAME +extrema -- find the extrema in an array of x and y points +.ih +SYNOPSIS +.nf +nextrema = extrema (x, y, curvature, npts, dx) + +real x[npts], y[npts] # Input data points and output extrema +real curvature[npts] # 2nd deriv. of cubic spline at extrema +int npts # Number of input data points +real dx # Precision of extrema positions +.fi +.ih +DESCRIPTION +The input data points are fitted with a cubic interpolation spline. The +spline is then searched for points where the first derivative changes sign. +The minimum step size of this search is controlled by the parameter dx. +The positions of these extrema are returned in the x array, the value of the +spline at the extrema are returned in the y array, and the curvature or +second derivative of the spline at the extrema are returned in the +curvature array. The function returns the number of extrema found. +.ih +SEE ALSO +xtools.peaks +.endhelp diff --git a/pkg/xtools/doc/inlfit.hlp b/pkg/xtools/doc/inlfit.hlp new file mode 100644 index 00000000..db256302 --- /dev/null +++ b/pkg/xtools/doc/inlfit.hlp @@ -0,0 +1,259 @@ +.help inlfit Aug91 xtools +.ih +NAME +inlfit -- The interactive non-linear least squares fitting package + +.ih +SYNOPSIS + +The INLFIT package is a set of procedures, callable from any IRAF task, +for interactively fitting an arbitrary function of n independent variables +using non-linear least squares techniques. The calling task +must supply the function to be fit and its derivatives, initial values for +various convergence and bad data rejection parameters, the data to be fit, +and weights for all the data points. The INLFIT package is layered on the +NLFIT package which does the actual fitting. + +.ih +DESCRIPTION + +INLFIT fits an n-dimensional function to a set of data +points iterating until the reduced chi-squared changes +by less than \fItolerance\fR percent between successive iterations, or +until machine precision is reached, or until +the maximum number +of iterations \fImaxiter\fR is reached. If the maximum number +of iterations is reached before convergence a status flag +is set. + +After computing an initial fit, INLFIT presents the user with a plot of +the fit and activates the graphics cursor. +At this point the user may examine and/or interact with the fit by, +for example, reprogramming the default graph keys, +editing the default convergence or bad data rejection parameters, +deleting and undeleting points, +altering which parameters in the fitting function are actually to be +fit and which are to be held constant, and refitting the data. + +If \fInreject\fR is greater than zero the RMS of the residuals is computed +and points whose residuals are less than \fIlow_reject\fR * RMS +or greater than \fIhigh_reject\fR * RMS value are excluded from the fit. +Points within +a distance \fIgrow\fR of a rejected point are also excluded from +the fit. The function is then refit without the rejected points. +The rejection algorithm is executed until the number of rejection +iterations reaches \fInreject\fR or no more points are rejected. + +.ih +CURSOR COMMANDS + +The following interactive cursor keystroke commands are available from +within the INLFIT package. +.ls ? +The terminal is cleared and a menu of cursor keystroke and colon commands +is printed. +.le +.ls c +The id, coordinates of the data point nearest the cursor, along with the +function value, the fitted value and the residual, are printed on the status +line. +.le +.ls d +The data point nearest the cursor and not previously deleted is marked with an +X. It will not be used in further fits until it is undeleted. +.le +.ls f +The function is fit to the data and the fit is graphed using the default +plot type. +.le +.ls g +Redefine the graph keys "h-l" from their defaults. A prompt is issued for the +graph key to be redefined. Another prompt is issued for the data to be +plotted at which point the user must enter the x and y axis data to plot, +delimited by a comma. The data types are the following (they can be +abbreviated to up to three characters). +.nf + + function Dependent variable or function + fit Fitted value + residuals Residuals (function - fit) + ratio Ratio (function / fit) + nonlinear Nonlinear component + identifier Independent variable named "identifier" (if defined) + var n Independent variable number "n" + user n User defined plot equation "n" (if defined) + +.fi +The application program can define independent variable names and user plot +functions, aside from the standard options provided. If variable names are +supplied, the user can reference them by their names. Otherwise they can be +always referenced by "var n", where "n" is the variable number (the user has +to know the variable order in this case). The ":variables" command will +list the currently defined variables by name and number. +The application program may +define any number of plot equations aside from the defaults provided. In this +case the user may reference them by "user n", where "n" is the plot function +number (the user must know the equation order in this case). +.le +.ls h, i, j, k, l +By default each key produces a different graph. The graphs are described by +the data which is graphed along each axis as defined above. The default graph +keys, +which may be redefined by the application program or interactively by using +the 'g' key, are the following. +.nf + + h function, fit + i function, residuals + j function, ratio + k var 1, function + l user 1, user 2 (default) + +.fi +The initial graph key, if not redefined by the application program is 'h'. +.le +.ls o +Overplot the next fit provided the graph format has not changed. +.le +.ls q +Exit from the interactive curve fitting package. +.le +.ls r +Redraw the current graph. +.le +.ls t +Toggle fit overploting on and off. If this option is on the data +and fitted values are overplotted. Otherwise only data points are plotted. +The fitted values are marked using boxes. +.le +.ls u +Undelete the data point nearest the cursor which has been previously deleted. +This option does not work over points marked as deleted by the application +program before calling inlfit. +.le +.ls w [key] +Set the graph window or data range along each axis to be graphed.. This is a +\fBgtools\fR option which prints the prompt "window:". The available cursor +keystroke commands are printed with '?' and on-line help is available by +typing "help gtools". +.le +.ls I +Interrupt the task immediately without saving the current fit. +.le + +Colon commands are used to show or set the values of parameters. +The application program calling \fBinlfit\fR can add more commands. +Parameter names can be abbreviated. The following commands are supported. +.ls :show [file] +Show the current values of the fitting parameters high_reject, +low_reject, niterate, grow, tol, itmax. The default output device +is the terminal (STDOUT) and the screen is cleared before the information +is output. If a file is specified then the information is appended +to the named file. +.le +.ls :variables [file] +List the currently loaded variables. The number, id, minimum value and maximum +value of each variable is printed. The default output device is the terminal +(STDOUT) and the screen is cleared before the information is output. +If a file is specified then the information is appended to the named file. +.le +.ls :data [file] +List the raw data. The value of each standard catalog and observations +catalog variable for each data point is printed. The default output device +is the terminal (STDOUT) and the screen is cleared before the information +is output. If a file is specified then the information is appended to +the named file. +.le +.ls :errors [file] +Show the error analysis of the current fit. The number of iterations, +total number of points, +the number of rejected and deleted points, the standard deviation, +the reduced chi, the average error (always = 1.0 if weight=1.0, otherwise += 1.0 / <weight>), the average scatter (always 0.0 if no weights scatter term is +fit), +the reduce chi, and the rms are printed on the screen. The fitted parameters +and their errors are also printed. The default output is the terminal +(STDOUT) and the screen is cleared before the information is +output. If a file is specified then the information is appended to +the named file. +.le +.ls :results [file] +List the results of the current fit. The function value, the fitted value, +the residual, and the weight are printed for each data point. The default +output device is the terminal (STDOUT) and the screen is cleared before +the information is output. If a file is specified then the information is +appended to the named file. +.le +.ls :vshow [file] +A verbose version of ":show" which is equivalent to a ":show" plus a ":errors" +plus a ":results". The default output device is the terminal (STDOUT) +and the screen is cleared before the information is output. +If a file is specified then the information is appended to the named file. +.le +.ls :page file +Page through the named file. +.le +.ls :tolerance [value] +Show or set the value of the fitting tolerance. Tolerance is the maximum +fraction by which the reduced chi-squared can change from one iteration to the +next for the fit to meet the convergence criteria. +.le +.ls :maxiter [value] +Show or set the maximum number of fitting iterations. +.le +.ls :nreject [value] +Show or set the maximum number of rejection iterations. A value of zero +means that automatic bad data rejection is turned off. +.le +.ls :low_reject [value], :high_reject [value] +Show or set the values of the bad data rejection limits. +If both low_reject and high_reject are zero then automatic bad data +rejection is turned off. +If either of the high or low rejection limits are greater than zero, +and nreject is greater than zero, the rms of the initial fit is computed. +Points with residuals +more than low_reject * rms below zero and high_reject * rms above zero +are removed before the final fit. Rejected points are marked on the +graphs with diamonds. +.le +.ls :grow [value] +Show or set the value of the rejection growing radius. Any points +within this distance of a rejected point are also rejected. +.le +.ls :fit [parameter] [value] +Set the starting guess value for the named coefficient and allow the +parameter value to change (converge) during the fit. +If the value is not specified inlfit will use the last starting guess. +.le +.ls :const [parameter] [value] +Set the named parameter to be a constant with the specified value, i.e, +its value won't change during the fit. +If the value is not specified inlfit will use its last starting value. +.le +.ls :/help +Print help for the graph formatting options. +.le +.ls :.help +Print help for the general IRAF graphics options. +.le + +.ih +ALGORITHMS + +INLFIT uses the standard Levenberg-Marquardt non-linear least squares +algorithm to fit the data. Detailed descriptions of the algorithm can +be found in the following two references. +.nf + +1. Bevington, P.R., 1969, Data Reduction and Error Analysis for the + Physical Sciences, Chapter 11, page 235. + +2. Press, W.H. et al., 1986, Numerical Recipes: The Art of Scientific + Computing, Chapter 14, page 523. + +.fi + +.ih +SEE ALSO +icfit,gtools +.endhelp diff --git a/pkg/xtools/doc/peaks.hlp b/pkg/xtools/doc/peaks.hlp new file mode 100644 index 00000000..dc9eb763 --- /dev/null +++ b/pkg/xtools/doc/peaks.hlp @@ -0,0 +1,28 @@ +.help peaks Jan84 xtools +.ih +NAME +peaks -- find the peaks in an array of x and y points +.ih +SYNOPSIS +.nf +npeaks = peaks (x, y, background, npts, dx) + +real x[npts], y[npts] # Input data points and output peaks +real background[npts] # Background estimate +int npts # Number of input data points +real dx # Precision of peak positions +.fi +.ih +DESCRIPTION +The extrema in the input data points are found using extrema(xtools). +The extrema are located to a precision of dx. +The extrema with negative curvature (peaks) are selected and returned +in the x array. The spline value is returned in the y array. The +background is estimated by linear interpolation of the neighboring +minima (extrema of positive curvature) to the position of the peak. +The background is returned in the background array. The number of +peaks found is returned as the function value. +.ih +SEE ALSO +xtools.extrema +.endhelp diff --git a/pkg/xtools/doc/ranges.hlp b/pkg/xtools/doc/ranges.hlp new file mode 100644 index 00000000..8f924698 --- /dev/null +++ b/pkg/xtools/doc/ranges.hlp @@ -0,0 +1,105 @@ +.help ranges Jan84 xtools +.ih +PURPOSE +These tools +parse a string using a syntax to represent integer values, ranges, and +steps. The parsed string is used to generate a list of integers for various +purposes such as specifying lines or columns in an image or tape file numbers. +.ih +SYNTAX +The syntax for the range string consists of non-negative integers, '-' (minus), +'x', ',' (comma), and whitespace. The commas and whitespace are ignored +and may be freely used for clarity. The remainder of the string consists +of sequences of five fields. The first field is the beginning of a range, +the second is a '-', the third is the end of the range, the fourth is +a 'x', and the fifth is a step size. Any of the five fields may be +missing causing various default actions. The defaults are illustrated in +the following table. + +.nf +-3x1 A missing starting value defaults to 1. +2-x1 A missing ending value defaults to MAX_INT. +2x1 A missing ending value defaults to MAX_INT. +2-4 A missing step defaults to 1. +4 A missing ending value and step defaults to an ending + value equal to the starting value and a step of 1. +x2 Missing starting and ending values defaults to + the range 1 to MAX_INT with the specified step. +"" The null string is equivalent to "1 - MAX_INT x 1", + i.e all positive integers. +.fi + +The specification of several ranges yields the union of the ranges. +Note that the default starting value is 1 though one may specify zero +as a range limit. +.ih +EXAMPLES +The following examples further illustrate the range syntax. + +.nf +- All positive integers. +1,5,9 A list of integers equivalent to 1-1x1,5-5x1,9-9x1. +x2 Every second positive integer starting with 1. +2x3 Every third positive integer starting with 2. +-10 All integers between 1 and 10. +5- All integers greater than or equal to 5. +9-3x1 The integers 3,6,9. +.fi +.ih +PROCEDURES + +.ls 4 decode_ranges + +.nf +int procedure decode_ranges (range_string, ranges, max_ranges, nvalues) + +char range_string[ARB] # Range string to be decoded +int ranges[3, max_ranges] # Range array +int max_ranges # Maximum number of ranges +int nvalues # The number of values in the ranges +.fi + +The range string is decoded into an integer array of maximum dimension +3 * max_ranges. Each range consists of three consecutive integers +corresponding to the starting and ending points of the range and the +step size. The number of integers covered by the ranges is returned +as nvalue. The end of the set of ranges is marked by a NULL. +The returned status is either ERR or OK. +.le +.ls 4 get_next_number, get_last_number + +.nf +int procedure get_next_number (ranges, number) +int procedure get_previous_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter +.fi + +Given a value for number the procedures find the next (previous) number in +increasing (decreasing) +value within the set of ranges. The next (previous) number is returned in +the number argument. A returned status is either OK or EOF. +EOF indicates that there are no greater values. The usual usage would +be in a loop of the form: + +.nf + number = 0 + while (get_next_number (ranges, number) != EOF) { + <Statements using number> + } +.fi +.le +.ls 4 is_in_range + +.nf +bool procedure is_in_range (ranges, number) + +int ranges[ARB] # Ranges array +int number # Number to check against ranges +.fi + +A boolean value is returned indicating whether number is covered by +the ranges. +.le +.endhelp diff --git a/pkg/xtools/doc/xtextns.hlp b/pkg/xtools/doc/xtextns.hlp new file mode 100644 index 00000000..f03f69ae --- /dev/null +++ b/pkg/xtools/doc/xtextns.hlp @@ -0,0 +1,115 @@ +.help xt_extns Mar07 xtools +.ih +NAME +.nf +xt_extns -- Expand an MEF into a list of image extensions +.fi +.ih +SYNOPSIS +.nf +int procedure xt_extns (files, index, extname, extver, lindex, lname, lver, + dataless, ikparams, err, imext) + +char files[ARB] #I List of MEF files +char index[ARB] #I Range list of extension indexes +char extname[ARB] #I Patterns for extension names +char extver[ARB] #I Range list of extension versions +int lindex #I List index number? +int lname #I List extension name? +int lver #I List extension version? +int dataless #I Include dataless image headers? +char ikparams[ARB] #I Image kernel parameters +int err #I Print errors? +int imext #O Image extensions? +.fi +.ih +DESCRIPTION +A list, \fIfiles\fR, of regular images and multi-extension FITS (MEF) +files is returned as a list of images. In addition a flag, \fIimext\fR, +is set indicating if image extensions are present. + +In order handle regular and MEF extension images in the same way one must +understand that all images in IRAF may be addressed with a numeric index +while those that are "regular" images may also be addressed without +an index. Non-FITS format images are considered to have an index of 1. +For example, an image in the IRAF format may be addressed +as pix.imh, pix, pix.imh[1], and pix[1]. FITS files start with index 0 +in order that index 1 may be used to refer to the first extension. +So a plain FITS image, say foo.fits may also be addressed as foo, foo[0], +or foo.fits[0]. If a FITS file has both a primary (index 0) image and +extensions then the zero index must be explicitly used. + +For regular images the index range must include 0 for FITS images (or +primary images in FITS files with extensions) and 1 for non-FITS images. +In the resulting list, the index notation is dropped unless it is required; +i.e. in a FITS file with both a primary image and extensions. + +The input set of candidate images may be filtered by index, extension +name, extension version, and whether images are dataless. + +\fIindex\fR is a range list (see \fBranges\fR) of indices to be applied +to each input file for identifying images. If a null string is +specified then all index values bet + +\fIindex\fR is a range list (see \fBranges\fR) of indices to be applied +to each input file for identifying images. If a null string is +specified then all non-negative index values are examined. + +\fIextname\fR is a comma delimited list of patterns for extension names. +If no list (a null string) or the string "*" is specified then no +filtering on the extension name is done. For a description of pattern +matching syntax see \fBmatch\fR. Extension names are those specified +by the EXTNAME keyword. For the purpose of explicit pattern matching +strings a missing EXTNAME keyword is treated as the extension name "none". +To include a comma in a pattern you must escape it by preceding it with +'\', however, a comma in an extension name may cause other problems +because IRAF image extension syntax using the extension name does not +allow commas or whitespace. Each pattern has '^' and '$' prepended +and appended respectively which means the pattern must match the entire +extension name. A common mistake is that '*' in a pattern is different +than '*' in a file template. In this case use '?*'. + +The reasons for a list of patterns matching the entire extension name +are to allow intuitive explicit lists of names, such as "im1,im11,im13", +and to deal with names which are difficult to unambiguously specify with +a single pattern. + +\fIextver\fR is a range list for extension version numbers. If no +list is given then no filtering on extension versions is performed. +See \fBranges\fR for more on range lists. + +\fIdataless\fR is a boolean parameter that selects whether to filter out +dataless images. Dataless images are uncommon except for a class of MEF +files where the primary image is used only for global inherited header +keywords. This parameter may be used to include this global header in +expansions of this type of MEF files. + +The output of the list of selected images for FITS image extensions may +be expressed either with the index notation (e.g. name[3]) or extension +name and/or extension version (e.g. name[im3], name[im5,2]). This is +controlled by the \fIlindex\fR, \fIlname\fR and \fIlver\fR boolean +parameters. If the extension name and or version number are selected +then that format is used even if \flindex\fR is also selected. If +there is no extension name or extension version then the index is used +even if \fIlindex\fR is not selected. Also remember that for regular +images where an index or extension sections is not required none will +be used. + +The output names may also include additional "image kernel" information. +Different image types, currently mostly for FITS images, have parameters +that may be specified in the image kernel section. The \fIikparams\fR +string may be used to add these additional parameters within the +kernel section part of the name. + +Finally, the input files, including MEF files, in the input file list +may include "image sections". During processing image sections are +stripped and then appended on the output. For example, name[1:10,1:10] +might expand to name[im1][1:10,1:10], name[im2][1:10,1:10], etc. + +\fIerr\fR may be used to print error messages when a particular image +index fails to be opened. Typically this would be to find nonexistent +or read-protected images and files. +.ih +SEE ALSO +mscextensions, imextensions, match, ranges +.endhelp diff --git a/pkg/xtools/doc/xtmaskname.hlp b/pkg/xtools/doc/xtmaskname.hlp new file mode 100644 index 00000000..ddc8a07c --- /dev/null +++ b/pkg/xtools/doc/xtmaskname.hlp @@ -0,0 +1,85 @@ +.help xt_maskname Mar07 xtools +.ih +NAME +.nf +xt_maskname -- create mask name +.fi +.ih +SYNOPSIS +.nf +procedure xt_maskname (fname, extname, mode, mname, maxchar) + +char fname[ARB] #I File name +char extname[ARB] #I Default pixel mask extension name +int mode #I Mode +char mname[maxchar] #O Output mask name +int maxchar #I Maximum characters in mask name +.fi +.ih +DESCRIPTION +This routine encapsulates creating a mask name from a user specified +name, an optional extension name, and an optional environment variable. +It checks if an explicit format is desired based on the presence of a +".pl" extension for a pixel list file or the FITS kernel parameter +"type=mask" (with the equal sign possibly escaped) for a FITS extension. +If neither is specified then the default is a FITS extension unless the +environment variable "masktype" is set to "pl". If the application +does not specify an extension name for FITS format the name "pl" is used. + +If the "masktype" environment variable is "pl" and the application requests +an extension name then a directory with the specified filename is used (and +created for a new mask) and the pixel list filename is the extension name. +For example, if the filename is "obj1234" and the extension name is "im1" +then the mask name is "obj1234/im1.pl". As a fallback if a directory +cannot be accessed the filename will have the form <fname>_<extname>.pl. + +Typically an application that specifically was designed to handle +multi-extension FITS (MEF) files will use the same extension name for +a mask as for the image extension to which it applies. +.ih +EXAMPLES +1. When "masktype" is undefined and creating a new mask: + +.nf + fname extname mname + -------------------------------------------------------- + abc "" --> abc[pl,type=mask] + abc "def" --> abc[def,type=mask] + abc[def,type=mask] "" --> abc[def,type=mask] + abc[def] "ghi" --> abc[def,type=mask] + abc.pl "" --> abc.pl + abc.pl "def" --> abc.pl +.fi + +2. When "masktype=pl" and creating a new mask: + +.nf + fname extname mname + -------------------------------------------------------- + abc "" --> abc.pl + abc "def" --> abc/def.pl + abc[def,type=mask] "" --> abc/def.pl + abc[def] "ghi" --> abc/def.pl + abc.pl "" --> abc.pl + abc.pl "def" --> abc.pl +.fi + +3. When reading a mask it looks for either format unless an explicit +".pl" extension is included. + +.nf + fname extname mname + -------------------------------------------------------- + abc "" --> abc[pl] + abc "def" --> abc[def] + abc[def,type=mask] "" --> abc[def,type=mask] + abc[def] "ghi" --> abc[def] + abc.pl "" --> abc.pl + abc.pl "def" --> abc.pl + abc "" --> abc.pl + abc "def" --> abc/def.pl + abc[def] "" --> abc/def.pl + abc[def] "ghi" --> abc/def.pl + abc[def] "" --> abc_def.pl +.fi +.endhelp diff --git a/pkg/xtools/doc/xtools.hd b/pkg/xtools/doc/xtools.hd new file mode 100644 index 00000000..38665086 --- /dev/null +++ b/pkg/xtools/doc/xtools.hd @@ -0,0 +1,45 @@ +# Help directory for the XTOOLS (programming tools) package. + +$xtools = "pkg$xtools/" +$fixpix = "pkg$xtools/fixpix/" +$icfit = "pkg$xtools/icfit/" +$gtools = "pkg$xtools/gtools/" +$ranges = "pkg$xtools/ranges/" +$skywcs = "pkg$xtools/skywcs/doc/" +$catquery = "pkg$xtools/catquery/doc/" + +revisions sys = xtools$Revisions +dttext hlp = xtools$dttext.x, src = .. +cogetr hlp = cogetr.hlp, src = xtools$cogetr.x +comap hlp = cogetr.hlp, src = xtools$cogetr.x +counmap hlp = cogetr.hlp, src = xtools$cogetr.x +xt_extns hlp = xtextns.hlp, src = xtools$xtextns.x +xt_lsum hlp = xtsums.hlp, src = xtools$xtsums.x +xt_csum hlp = xtsums.hlp, src = xtools$xtsums.x +xt_lsumb hlp = xtsums.hlp, src = xtools$xtsums.x +xt_lsuml hlp = xtsums.hlp, src = xtools$xtsums.x +xt_maskname hlp = xtmaskname.hlp, src = xtools$xtmaskname.x +xt_pmmap hlp = xtpmmap.hlp, src = fixpix$xtpmmap.x +clgsec hlp = clgsec.hlp, src = xtools$clgsec.x +extrema hlp = extrema.hlp, src = xtools$extrema.x +getdatatype hlp = getdatatype.hlp, src = xtools$getdatatype.x +gstrdetab hlp = gstrdetab.hlp, src = xtools$gstrdetab.x +gstrentab hlp = gstrentab.hlp, src = xtools$gstrentab.x +gstrsettab hlp = gstrsettab.hlp, src = xtools$gstrsettab.x +peaks hlp = peaks.hlp, src = xtools$peaks.x +ranges hlp = ranges.hlp, src = xtools$ranges.x +strdetab hlp = strdetab.hlp, src = xtools$strdetab.x +strentab hlp = strentab.hlp, src = xtools$strentab.x +center1d hlp = center1d.hlp, src = xtools$center1d.x +icfit hlp = icfit$icfit.hlp +inlfit hlp = xtools$doc/inlfit.hlp +#gtools hlp = gtools$gtools.hlp, pkg = gtools$gtools.hd +gtools hlp = gtools$gtools.hlp + +skywcs hlp = skywcs$skywcs.men, + sys = skywcs$skywcs.hlp, + pkg = skywcs$skywcs.hd + +catquery hlp = catquery$catquery.men, + sys = catquery$catquery.hlp, + pkg = catquery$catquery.hd diff --git a/pkg/xtools/doc/xtools.men b/pkg/xtools/doc/xtools.men new file mode 100644 index 00000000..8fe85373 --- /dev/null +++ b/pkg/xtools/doc/xtools.men @@ -0,0 +1,23 @@ + catquery - Catalog query package + clgsec - Get and decode an image section + clginterp - Get integer code for interpolator type + cogetr - Efficient image column access + comap - Map for column access procedure + counmap - Unmap for column access procedure + extrema - Find extrema in x and y data points + getdatatype - Convert type suffix character to TY_ type code + gstrdetab - Remove tabs from a string + gstrentab - Put tabs in a string where possible + gstrsettab - Set tab stops for gstrdetab, entab. + gtools - Graphics tools + icfit - Interactive curve fitting package + inlfit - Interactive non-linear least squares fitting package + peaks - Find peaks in x and y data points + ranges - Parse a list of ranges "1,3,5-7,.." + skywcs - Celestial coordinates transformation package + strdetab - Simplified detab + strentab - Simplified entab + xt_csum - Sum of image columns using column access procedure + xt_csumb - Buffered sum of image columns using column access procedure + xt_lsum - Sum of image lines + xt_lsumb - Buffered sum of image lines for moving sums diff --git a/pkg/xtools/doc/xtpmmap.hlp b/pkg/xtools/doc/xtpmmap.hlp new file mode 100644 index 00000000..94752da3 --- /dev/null +++ b/pkg/xtools/doc/xtpmmap.hlp @@ -0,0 +1,144 @@ +.help xt_pmmap Mar07 xtools +.ih +NAME +.nf +xt_pmmap -- map a mask and match it to a reference image +.fi +.ih +SYNOPSIS +.nf +# Open a mask. +pointer procedure xt_pmmap (pmname, refim, mname, sz_mname) + +char pmname[ARB] #I Pixel mask name +pointer refim #I Reference image pointer +char mname[ARB] #O Expanded mask name +int sz_mname #O Size of expanded mask name + + +# Close the mask. +procedure xt_pmunmap (im) + +pointer im #I IMIO pointer for mask +.fi +.ih +DESCRIPTION +This interface maps (opens) and unmaps (closes) a mask for use in an +application. It includes resolving mask files from image header keywords +in a reference image, inverting masks, matching masks spatially to a +reference image, and access to non-pixel list formats. + +The \fIpmname\fR argument is a file name or a reference to an image header +keyword using the syntax "!<keyword>". As a special case the name "BPM" +is equivalent to "!BPM". It is also legal for the file name to be a null +string which returns a NULL pointer for the application to interpret +as desired. Most applications will treat this case as all image pixels +are good. + +If the file name, or the file name obtained from a keyword reference, +begins with the character '^' the mask will be inverted to a boolean mask. +This means that input mask values which are zero are set to 1 and non-zero +mask values are set to 0. + +The \fIrefim\fR argument is the IMIO image pointer for a reference image +used to resolve keyword references and for spatial matching. + +The map routine returns the mask name through the \fImname\fR argument. +Typically an application would use the mask name for logging purposes +since it will expand keyword mask references. + +.sh +SPATIAL MATCHING + +The matching of masks to a reference image is a powerful feature though it +can also cause confusion. The advantage of matching is that when images +are modified by trimming or other linear geometric operations the mask, +often referenced in the image header, will still correctly identify +the bad pixels. Note that this does not apply to non-linear coordinate +transformations. + +The matching is based on a "physical" coordinate system. This is typically +the image pixel coordinate system prior to any linear transformation. +IRAF tasks which extract subrasters, subsample, block average, block +replicate, transpose, etc. update header keywords describing the mapping +from the image pixel coordinate system (called the "logical" coordinate +system) to the parent physical coordinate system. Some applications +also attach a meaning to the physical coordinate system such as detector +array coordinates. + +The transformation between logical coordinates (lx,ly) and physical +coordinates (px,py) is defined by the header keywords LTM1_1, LTM2_1, +LTM1_2, LTM_2_2, LTV1, and LTV2 as shown below. + +.nf + lx = px * LTM1_1 + py * LTM2_1 + LTV1 + ly = px * LTM1_2 + py * LTM2_2 + LTV2 + + px = ( LTM2_2 * (lx - LTV1) - LTM2_1 * (ly - LTV2)) / + (LTM1_1 * LTM2_2 - LTM1_2 * LTM2_1) + py = (-LTM1_2 * (lx - LTV1) + LTM1_1 * (ly - LTV2)) / + (LTM1_1 * LTM2_2 - LTM1_2 * LTM2_1) +.fi + +Note that a missing keyword defaults to a value of zero. When all +LTM/LTV keywords are missing then the physical and logical coordinate +systems are identical. In other words the implied transformation is +an identify transformation. Note that one cannot just have +LTV keywords because then the implied transformation matrix is +ill-defined (all matrix elements are assumed zero). + +The matching consists of deriving a transformation between the +logical pixels in the image and the mask by combining the two physical +transformations. This means that even if the logical to physical +transformations are complex, such as a rotation, if the two are the same +a identity or a simple offset relative transformation may still exist +between the two. In this combined logical-to-logical transformation +the current version does not allow a rotation though, as just noted, the +separate logical-to-pixel transformation may be rotated by the same amount. + +When the image is sampled more finely than the mask, that is the same mask +pixel overlaps multiple image pixels, then the nearest mask value (pixel +center to pixel center) is used for each image pixel. When the image is +more coarsely sampled, that is more than one mask pixel overlaps an image +pixel, then the maximum mask value becomes the mask value for the pixel. +This latter choice means that if an image pixel is touched by any bad +pixel then it will be indicated as bad. + +If after matching the mask to the image the mask does not cover +the image, the mask is extended by adding zero mask values. + +The above description is fairly general which makes this seem complex. +However, by far the most common mismatch between an image and its mask +is that an image has been derived as a subraster of a parent image. +In this case the LTM values will be LTM1_1=LTM2_2=1 and LTM2_1=LTM1_2=0 +(or missing) and the matching just depends on the origin offset keywords +LTV1 and LTV2. + +Note that to eliminate this matching one resets the physical coordinate +system to be equivalent to the logical coordinate system. The task +\fIwcsreset\fR can be used or the above LTM/LTV keywords can be deleted +using a header keyword editor. + +.sh +ALTERNATIVE MASK DESCRIPTIONS + +This interface accepts alternate mask descriptions that are internally +converted to the same mask structure for transparent use by the application. +The preferred input mask description is a pixel mask in either pixel list +format (.pl extension) or a FITS pixel mask (a binary table representation). +The alternate representations are a regular image and a text description. + +The pixels values in a regular image are truncated (towards zero) to integers. +Then negative values are set to 0. + +A text description consists of lines in a text file with either two or +four values. The values are truncated to integers if needed. Two values +define a mask value of 2 at the (x,y) coordinate. Four values define a +region, given as (x1,x2,y1,y2) of mask values. The mask values are 2 if +the width of the region is narrower or equal to the height. Otherwise the +value is 3. This is a convention used by task which then interpolate +across bad pixel regions. + +Note that a text description is always tied directly to the input +image; that is, the physical and logical coordinate systems are the same. +.endhelp diff --git a/pkg/xtools/doc/xtsums.hlp b/pkg/xtools/doc/xtsums.hlp new file mode 100644 index 00000000..c91ef644 --- /dev/null +++ b/pkg/xtools/doc/xtsums.hlp @@ -0,0 +1,83 @@ +.help xtsums Feb86 xtools +.ih +NAME +.nf +xt_lsum -- Sum image lines +xt_csum -- Sum image columns +xt_lsumb -- Sum image lines with buffering +xt_csumb -- Sum image columns with buffering +.fi +.ih +SYNOPSIS +.nf +pointer im # IMIO pointer +pointer co # COGETR pointer +int col1, col2 # Column limits of the sum +int line1, line2 # Line limits +pointer data # Data pointer returned + + call xt_lsum (im, col1, col2, line1, line2, data) + call xt_csum (co, col1, col2, line1, line2, data) + call xt_lsumb (im, col1, col2, line1, line2, data) + call xt_csumb (co, col1, col2, line1, line2, data) +.fi +.ih +DESCRIPTION +The specified lines or columns in a 2D images are summed and a pointer to +the real sum vector is returned. For \fBxt_lsum\fR and \fBxt_lsumb\fR the +lines between \fIline1\fR and \fIline2\fR are summed and a pointer to the summed +vector between \fIcol1\fR and \fIcol2\fR is returned. Similarly, for +\fBxt_csum\fR and \fBxt_csumb\fR the columns between \fIcol1\fR and \fIcol2\fR +are summed and a pointer to the summed vector between \fIline1\fR and +\fIline2\fR is returned. The data pointer is to a real vector. The column +sums use the efficient column access procedures described in \fBcogetr\fR. + +The procedures without the 'b' suffix read the set of lines or columns +in the sum from the image every time. The 'b' suffix procedures buffer +the lines or columns such that if only a few lines or columns are different +from the preceding sum then only those lines or columns are read. Thus the +"buffered" sums are used for moving sums while the unbuffered procedures are +used when there is no overlap between the sums. +.ih +RETURN VALUE +The returned pointer \fIdata\fR is to a vector of type real. +.ih +EXAMPLES +Suppose a sum of "nsum" lines or columns is required through the image +in steps of "nstep". The following code fragment illustrates the usage. + +.nf + im = immap (image, READ_ONLY, 0) + switch (axis) { + case 1: + col1 = 1 + col2 = IM_LEN(im, 1) + for i = 1, IM_LEN(im, 2), nstep { + if (nstep < nsum) + call xt_lsumb (co, col1, col2, i, i+nsum-1, data) + else + call xt_lsum (co, i, i+nsum-1, line1, line2, data) + + # Do operations on vector Memr[data] + } + case 2: + co = comap (im, maxbuf) + + line1 = 1 + line2 = IM_LEN(im, 2) + for i = 1, IM_LEN(im, 1), nstep { + if (nstep < nsum) + call xt_csumb (co, i, i+nsum-1, line1, line2, data) + else + call xt_csum (co, i, i+nsum-1, line1, line2, data) + + # Do operations on vector Memr[data] + } + call counmap (co) + } + call imunmap (im) +.fi +.ih +SEE ALSO +cogetr +.endhelp diff --git a/pkg/xtools/dttext.x b/pkg/xtools/dttext.x new file mode 100644 index 00000000..387d8654 --- /dev/null +++ b/pkg/xtools/dttext.x @@ -0,0 +1,698 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <time.h> +include <ctype.h> +include <ctotok.h> +include <error.h> +include <fset.h> +include <pkg/dttext.h> + +.help dttext May85 "Simple Text Database Tools" +.ih +DESCRIPTION + +The database created, accessed, and modified by these procedures is +a simple text file. The purpose of these tools is to act as +an interum database facility until the sophisticated IRAF database +package is available. The database model consists of +comment lines which begin with a #, records, and fields within records. +Records and fields (except array fields) have the same format, a keyword +followed by data and terminated by a newline. Records have the keyword +'begin' and the data is any following text. Thus a record can be identified +by anything from a single character to an entire string. A record contains +all the following lines until the next record or the end of the file. +Whitespace before and after the keyword is ignored. The user is responsible +for adding indentation to clarify the structure +of the database. However, the user can create a database with any +style of whitespace that satisfies the keyword/value syntax. + +The array fields have a slightly different format. The field begins just +like an integer valued field; keyword followed by an integer. The integer +value is the number of array elements. The following lines +contain the array values, one per line. Because the field name +line has the same structure as an integer valued field the array +length can be determined before reading the array values by reading +the field as integer valued. + +For arrays with more than one column per line the dtscan procedure is +used to scan a line and then the FMTIO garg procedures are used to +decode the columns. The user read the array field as an integer to get +the number of lines and to position FIO to start reading the lines. + +There are four types of fields currently supported. These are integer +valued fields, real valued fields, string valued fields, and real arrays. +It is up to the user to know the type of value for each field. Note +that the integer and real fields may be accessed as string valued. + +Records are referenced by a record number. When a database is mapped +each record which is unique is given a sequential record number. +When more than one record has the same record identifier then only +the last record is mapped. + +There are limitations imposed by the text file format. A database +may only be read or appended. To update a record a new record must +be written. A later record with the same name takes precedence. + +Errors are handled through the standard error handling system of IRAF. +Thus, uncaught errors will terminate the task with a message. If it +is possible that a field will not be present then the task can catch +the error and take appropriate action. +.ih +DATABASE MAPPING + +When a database is mapped READ_ONLY then the records in the database +are found and a structure created. The structure is given in the file +"dttext.h". The important elements of the structure are: + +.nf + + DT(dt) # Database FIO channel + DT_NRECS(dt) # Number of records + DT_NAME(dt, rec) # Record name + DT_OFFSET(dt, rec) # FIO offset +.fi +.ih +PROCEDURES + +The procedures separate into three types, procedures to map and unmap +the database, procedures to access the database, and procedures to make +entries in the database. The access routines reference a particular +record. To access a record by name the procedure dtlocate returns +the record number or EOF. The put routines write to the end of +the database. It is important to enter a record because otherwise +added fields will be associated with the preceding record. The put +time command puts a comment line with the time. + +.nf + dt = dtmap (database, mode) # NEW_FILE, READ_ONLY or APPEND + dt = dtmap1 (database, name, mode) # Use a directory as a database + dtremap (dt, database, name,mode) # Remap a database + dtunmap (dt) + + record = dtlocate (dt, recname) + + dtgstr (dt, record, field, str, maxchar) + value = dtget[ird] (dt, record, field) + dtgar (dt, record, field, array, len_array, npts) + + dtptime (dt) + dtput (dt, format) +.fi +.ih +EXAMPLES + +The following is an example record from a database. + +.nf +# Fri 15:13:13 05-Apr-85 Example +begin NGC1952 B + title NGC1952 B filter centered + ra 12:40:20 + dec +5:20:15 + flags 4 + 3.1 + 9.2 + 1 + 4 + exp 3600 +.fi + + +The following example reads the example record and writes a new record. + +.nf + iferr { + dt = dtmap (database, READ_ONLY) + record = dtlocate (dt, "NGC1952 B") + call dtgstr (dt, record, "title", title, SZ_TITLE) + ra = dtgetr (dt, record, "RA") + dec = dtgetr (dt, record, "DEC") + + # Get length of array for dynamic allocation. + nflags = dtgeti (dt, record, "flags") + call salloc (flags, nflags, TY_REAL) + call dtgar (dt, record, "flags", Memr[flags], nflags, nflags) + } + + dt = dtmap (database, APPEND) + call dtptime (dt) + call dtput (dt, "begin\tNGC1952 Objects\n") + call dtput (dt, "\tobjects\t10\n) + do i = 1, 10 { + call dtput (dt, "\t\t%g\n") + call pargr (objects[i]) + } + call dtclose (dt) +.fi + +The following is a database entry for a list which is read by the code below. + +.nf +# Fri 15:13:13 05-Apr-85 Example +begin Table 1 + 1 apples 10 macintosh + 2 oranges 8 valencia + 3 potatoes 3 idaho + + + # Code to read database table. + + record = dtlocate (dt, "Table 1") + call seek (DT(dt), DT_OFFSET(dt, record)) + while (scan (DT(dt)) != EOF) { + call gargi (n) + call gargwrd (fruit[1, n]) + call gargi (number[n]) + call gargstr (comment[1, n]) + } + +To read sequentially through a database: + + # Code to read sequentially through a database. + + do i = 1, DB_NRECS(db) { + call printf ("%s\n") + call pargstr (DB_NAME(db, i)) + } +.fi +.ih +SEE ALSO +Source code +.endhelp + + +# DTMAP -- Map a database. + +pointer procedure dtmap (database, mode) + +char database[ARB] # Database file +int mode # FIO mode + +int i, nrec +int dt_alloc1, dt_alloc2 +pointer dt, str + +int open(), fscan(), strlen() +bool streq() +long note() +errchk delete, open + +begin + if (mode == NEW_FILE) + iferr (call delete (database)) + ; + + i = open (database, mode, TEXT_FILE) + + call calloc (dt, DT_LEN, TY_STRUCT) + DT(dt) = i + + if (mode != READ_ONLY) + return (dt) + + dt_alloc1 = DT_ALLOC + dt_alloc2 = DT_ALLOC * SZ_LINE + call malloc (DT_OFFSETS(dt), dt_alloc1, TY_LONG) + call malloc (DT_NAMES(dt), dt_alloc1, TY_INT) + call malloc (DT_MAP(dt), dt_alloc2, TY_CHAR) + call malloc (str, SZ_LINE, TY_CHAR) + + nrec = 1 + DT_NRECS(dt) = 0 + DT_NAMEI(dt, nrec) = 0 + + while (fscan (DT(dt)) != EOF) { + call gargwrd (DT_NAME(dt, nrec), SZ_LINE) + + if (streq (DT_NAME(dt, nrec), "begin")) { + call gargstr (Memc[str], SZ_LINE) + for (i=str; IS_WHITE(Memc[i]); i=i+1) + ; + call strcpy (Memc[i], DT_NAME(dt,nrec), SZ_LINE) + + for (i = 1; i < nrec; i = i + 1) + if (streq (DT_NAME(dt, i), DT_NAME(dt, nrec))) + break + + if (i < nrec) + DT_OFFSET(dt, i) = note (DT(dt)) + else { + DT_NRECS(dt) = nrec + DT_OFFSET(dt, nrec) = note (DT(dt)) + DT_NAMEI(dt, nrec+1) = DT_NAMEI(dt, nrec) + + strlen (DT_NAME(dt, nrec)) + 1 + nrec = nrec + 1 + } + + if (nrec == dt_alloc1) { + dt_alloc1 = dt_alloc1 + DT_ALLOC + call realloc (DT_OFFSETS(dt), dt_alloc1, TY_LONG) + call realloc (DT_NAMES(dt), dt_alloc1, TY_INT) + } + if (DT_NAMEI(dt, nrec) + SZ_LINE >= dt_alloc2) { + dt_alloc2 = dt_alloc2 + DT_ALLOC * SZ_LINE + call realloc (DT_MAP(dt), dt_alloc2, TY_CHAR) + } + } + } + + call realloc (DT_MAP(dt), DT_NAMEI(dt, nrec), TY_CHAR) + call realloc (DT_OFFSETS(dt), DT_NRECS(dt), TY_LONG) + call realloc (DT_NAMES(dt), DT_NRECS(dt), TY_INT) + call mfree (str, TY_CHAR) + + return (dt) +end + + +# DTCLOSE -- Close database. + +procedure dtunmap (dt) + +pointer dt # Database file descriptor + +begin + if (dt == NULL) + return + call close (DT(dt)) + call mfree (DT_MAP(dt), TY_CHAR) + call mfree (DT_OFFSETS(dt), TY_LONG) + call mfree (DT_NAMES(dt), TY_INT) + call mfree (dt, TY_STRUCT) +end + + +# DTLOCATE -- Locate a database record. + +int procedure dtlocate (dt, name) + +pointer dt # DTTEXT pointer +char name[ARB] # Record name + +int i + +bool streq() + +begin + do i = 1, DT_NRECS(dt) { + if (streq (name, DT_NAME(dt, i))) + return (i) + } + +# call printf ("Record = %s\n") +# call pargstr (name) +# call flush (STDOUT) + call error (0, "Database record not found") +end + + +# DTGSTR -- Get a string field + +procedure dtgstr (dt, record, field, str, maxchar) + +pointer dt # Database file descriptor +int record # Database index +char field[ARB] # Database field +char str[maxchar] # String value +int maxchar # Maximum characters for string + +char name[SZ_LINE] +int i, fscan() +bool streq() + +begin + if ((record < 1) || (record > DT_NRECS(dt))) + call error (0, "Database record request out of bounds") + + call seek (DT(dt), DT_OFFSET(dt, record)) + + while (fscan (DT(dt)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargstr (str, maxchar) + for (i=1; IS_WHITE(str[i]); i=i+1) + ; + if (i > 1) + call strcpy (str[i], str, maxchar) + return + } + } + + call error (0, "Database field not found") +end + + +# DTGETI -- Get an integer field + +int procedure dtgeti (dt, record, field) + +pointer dt # DTTEXT pointer +int record # Database index +char field[ARB] # Database field + +int ival # Field value +char name[SZ_LINE] + +int fscan(), nscan() +bool streq() + +begin + if ((record < 1) || (record > DT_NRECS(dt))) + call error (0, "Database record request out of bounds") + + call seek (DT(dt), DT_OFFSET(dt, record)) + + while (fscan (DT(dt)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargi (ival) + if (nscan() == 2) + return (ival) + else + call error (0, "Error in database field value") + } + } + + call error (0, "Database field not found") +end + + +# DTGETR -- Get an real field + +real procedure dtgetr (dt, record, field) + +pointer dt # DTTEXT pointer +int record # Database index +char field[ARB] # Database field + +real rval +char name[SZ_LINE] + +int fscan(), nscan() +bool streq() + +begin + if ((record < 1) || (record > DT_NRECS(dt))) + call error (0, "Database record request out of bounds") + + call seek (DT(dt), DT_OFFSET(dt, record)) + + while (fscan (DT(dt)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargr (rval) + if (nscan() == 2) + return (rval) + else + call error (0, "Error in database field value") + } + } + + call error (0, "Database field not found") +end + + +# DTGETD -- Get a doubel precision field. + +double procedure dtgetd (dt, record, field) + +pointer dt # DTTEXT pointer +int record # Database index +char field[ARB] # Database field + +double dval +char name[SZ_LINE] + +int fscan(), nscan() +bool streq() + +begin + if ((record < 1) || (record > DT_NRECS(dt))) + call error (0, "Database record request out of bounds") + + call seek (DT(dt), DT_OFFSET(dt, record)) + + while (fscan (DT(dt)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargd (dval) + if (nscan() == 2) + return (dval) + else + call error (0, "Error in database field value") + } + } + + call error (0, "Database field not found") +end + + +# DTGAR -- Get a real array field + +procedure dtgar (dt, record, field, array, len_array, npts) + +pointer dt # DTTEXT pointer +int record # Database index +char field[ARB] # Database field +real array[len_array] # Array values +int len_array # Length of array +int npts # Number of points in the array + +char name[SZ_LINE] +int i + +int fscan(), nscan() +bool streq() + +begin + if ((record < 1) || (record > DT_NRECS(dt))) + call error (0, "Database record request out of bounds") + + call seek (DT(dt), DT_OFFSET(dt, record)) + + while (fscan (DT(dt)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargi (npts) + if (nscan() != 2) + call error (0, "Error in database field value") + + npts = min (npts, len_array) + for (i = 1; i <= npts; i = i + 1) { + if (fscan (DT(dt)) == EOF) + call error (0, "Error in database field value") + + call gargr (array[i]) + if (nscan() != 1) + call error (0, "Error in database field value") + } + return + } + } + + call error (0, "Database field not found") +end + + +# DTGAD -- Get a double array field + +procedure dtgad (dt, record, field, array, len_array, npts) + +pointer dt # DTTEXT pointer +int record # Database index +char field[ARB] # Database field +double array[len_array] # Array values +int len_array # Length of array +int npts # Number of points in the array + +char name[SZ_LINE] +int i + +int fscan(), nscan() +bool streq() + +begin + if ((record < 1) || (record > DT_NRECS(dt))) + call error (0, "Database record request out of bounds") + + call seek (DT(dt), DT_OFFSET(dt, record)) + + while (fscan (DT(dt)) != EOF) { + call gargwrd (name, SZ_LINE) + + if (streq (name, "begin")) + break + else if (streq (name, field)) { + call gargi (npts) + if (nscan() != 2) + call error (0, "Error in database field value") + + npts = min (npts, len_array) + for (i = 1; i <= npts; i = i + 1) { + if (fscan (DT(dt)) == EOF) + call error (0, "Error in database field value") + + call gargd (array[i]) + if (nscan() != 1) + call error (0, "Error in database field value") + } + return + } + } + + call error (0, "Database field not found") +end + + +# DTPTIME -- Put a time string with a comment + +procedure dtptime (dt) + +pointer dt # DTTEXT pointer + +char timestr[SZ_TIME] +long time, clktime() + +begin + time = clktime (0) + call cnvtime (time, timestr, SZ_TIME) + call fprintf (DT(dt), "# %s\n") + call pargstr (timestr) +end + + +# DTPUT -- Print to database. + +procedure dtput (dt, format) + +pointer dt # DTTEXT pointer +char format[ARB] # String format + +begin + call fprintf (DT(dt), format) +end + +# DTSCAN -- Scan database. + +int procedure dtscan (dt) + +pointer dt # DTTEXT pointer + +int fscan() + +begin + return (fscan (DT(dt))) +end + + +include <finfo.h> + +# DTMAP1 -- Map database. +# +# The database name may be a regular file or a directory. If it is a +# directory a database file with the name given by key is read or appended. + +pointer procedure dtmap1 (database, key, mode) + +char database[ARB] # Database +char key[ARB] # Key +int mode # Mode + +pointer sp, dbfile, dt + +int isdirectory(), access(), stridxs() +pointer dtmap() + +errchk dtmap() + +begin + call smark (sp) + call salloc (dbfile, SZ_PATHNAME + SZ_FNAME, TY_CHAR) + + # Check if the database does not exist create it as a directory. + + if (access (database, READ_ONLY, DIRECTORY_FILE) == NO) + if ((mode == APPEND) || (mode == NEW_FILE)) { + if (stridxs (".", database) != 0) + call error (0, + "Periods not allowed in database directory name") + iferr (call fmkdir (database)) + call error (0, "Can't make database directory") + } + + if (isdirectory (database, Memc[dbfile], SZ_PATHNAME + SZ_FNAME) > 0) + call strcat (key, Memc[dbfile], SZ_PATHNAME + SZ_FNAME) + else + call strcpy (database, Memc[dbfile], SZ_PATHNAME + SZ_FNAME) + + dt = dtmap (Memc[dbfile], mode) + call strcpy (database, DT_DNAME(dt), DT_SZFNAME) + call strcpy (key, DT_FNAME(dt), DT_SZFNAME) + DT_MODE(dt) = mode + + call sfree (sp) + return (dt) +end + + +# DTREMAP -- Check if database needs to be remapped. +# +# If the pointer is null simply map the database. +# If the pointer is not null check if the requested database is the same +# as the current one and if not close the current database and map the +# new one. Note that remapping between read and append will not update +# the entry data structure to include any information written. + +procedure dtremap (dt, dname, fname, mode) + +pointer dt # Database pointer +char dname[ARB] # Directory name +char fname[ARB] # File name +int mode # Mode + +int i, open() +bool strne() +pointer dbfile, dtmap1() +errchk dtmap1, dtunmap + +begin + if (dt != NULL) { + if (strne (dname, DT_DNAME(dt)) || strne (fname, DT_FNAME(dt))) { + call dtunmap (dt) + } else if (mode != DT_MODE(dt)) { + i = SZ_PATHNAME + SZ_FNAME + call malloc (dbfile, i, TY_CHAR) + call fstats (DT(dt), F_FILENAME, Memc[dbfile], i) + call close (DT(dt)) + iferr (i = open (Memc[dbfile], mode, TEXT_FILE)) { + DT(dt) = NULL + call dtunmap (dt) + call mfree (dbfile, TY_CHAR) + call erract (EA_ERROR) + } + DT(dt) = i + DT_MODE(dt) = mode + call mfree (dbfile, TY_CHAR) + } + } + + if (dt == NULL) { + i = dtmap1 (dname, fname, mode) + dt = i + } +end diff --git a/pkg/xtools/extrema.x b/pkg/xtools/extrema.x new file mode 100644 index 00000000..0a373aa5 --- /dev/null +++ b/pkg/xtools/extrema.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define ORDER 4 # The order of the spline + +# EXTREMA -- Find the extrema in an array of x and y points. +# The input data points are fitted with a cubic interpolation spline. The +# spline is then searched for points where the first derivative changes sign. +# The minimum step size of this search is controlled by the parameter dx. +# The positions of these extrema are returned in the x array, the value of the +# spline at the extrema are returned in the y array, and the curvature or +# second derivative of the spline at the extrema are returned in the +# curvature array. The function returns the number of extrema found. + +int procedure extrema (x, y, curvature, npts, dx) + +real x[npts], y[npts] # Input data points and output extrema +real curvature[npts] # 2nd deriv. of cubic spline at extrema +int npts # Number of input data points +real dx # Precision of extrema positions + +int i, ier, nextrema +real xeval, left_deriv, right_deriv +pointer sp, bspln, q +real seval() +errchk salloc, seval + +begin + # Allocate working arrays for spline routines + call smark (sp) + call salloc (bspln, 2 * npts + 30, TY_REAL) + call salloc (q, (2 * ORDER - 1) * npts, TY_REAL) + + # Calculate the spline coefficients + call spline (x, y, npts, Memr[bspln], Memr[q], ORDER, ier) + if (ier != 0) { + call sfree (sp) + return (0) + } + + # Initialize the curvature array + call aclrr (curvature, npts) + + # Find the extrema defined by a change in sign in the first derivative. + nextrema = 0 + left_deriv = seval (x[1], 1, Memr[bspln]) + do i = 2, npts { + xeval = x[i] + right_deriv = seval (xeval, 1, Memr[bspln]) + if (left_deriv * right_deriv <= 0.) { + for (xeval = x[i - 1] + dx; xeval <= x[i]; xeval = xeval + dx) { + right_deriv = seval (xeval, 1, Memr[bspln]) + if (left_deriv * right_deriv <= 0.) + break + left_deriv = right_deriv + } + nextrema = nextrema + 1 + x[nextrema] = xeval + y[nextrema] = seval (xeval, 0, Memr[bspln]) + curvature[nextrema] = seval (xeval, 2, Memr[bspln]) + if (curvature[nextrema] == 0.) + nextrema = nextrema - 1 + if (nextrema == npts) + break + } + left_deriv = right_deriv + } + + call sfree (sp) + return (nextrema) +end diff --git a/pkg/xtools/fixpix/mkpkg b/pkg/xtools/fixpix/mkpkg new file mode 100644 index 00000000..4d91ae71 --- /dev/null +++ b/pkg/xtools/fixpix/mkpkg @@ -0,0 +1,25 @@ +# XT_FIXPIX package. + +$checkout libxtools.a lib$ +$update libxtools.a +$checkin libxtools.a lib$ +$exit + +generic: + $set GEN = "$$generic -k" + $ifolder (xtfp.x, xtfp.gx) + $(GEN) xtfp.gx -o xtfp.x $endif + ; + +libxtools.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + setfp.x <imhdr.h> <imset.h> <pmset.h> + xtfixpix.x <imhdr.h> <imset.h> <pmset.h> xtfixpix.h + xtfp.x <imhdr.h> <pmset.h> xtfixpix.h + xtpmmap.x <ctype.h> <error.h> <imhdr.h> <imset.h> <mach.h>\ + <mwset.h> <pmset.h> + ytfixpix.x <imhdr.h> <imset.h> <pmset.h> xtfixpix.h + ytpmmap.x <ctype.h> <error.h> <imhdr.h> <imset.h> <mach.h>\ + <mwset.h> <pmset.h> + ; diff --git a/pkg/xtools/fixpix/setfp.x b/pkg/xtools/fixpix/setfp.x new file mode 100644 index 00000000..5fe2f5c1 --- /dev/null +++ b/pkg/xtools/fixpix/setfp.x @@ -0,0 +1,72 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <pmset.h> + + +# SET_FP -- Set the fixpix mask. +# +# This routine transforms the input mask values into the output mask +# values. It allows the input mask to have two classes of bad pixels; +# those which are interpolated and those which are not. + +procedure set_fp (im, fp) + +pointer im #I Input mask image pointer +pointer fp #O FIXPIX interpolation pointer + +int i, j, nc, nl +long v[2] +pointer data1, data2, pm, pmi + +int imstati(), pm_newcopy() +pointer yt_fpinit() +errchk malloc, yt_fpinit + +begin + # Set the image size and data buffers. + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + call malloc (data1, nc, TY_SHORT) + call malloc (data2, nc, TY_SHORT) + + # Get the pixel mask from the image. + pm = imstati (im, IM_PMDES) + + # Extract the pixels to be interpolated. + pmi = pm_newcopy (pm) + v[1] = 1 + do j = 1, nl { + v[2] = j + call pmglps (pm, v, Mems[data1], 0, nc, PIX_SRC) + do i = 0, nc-1 { + if (Mems[data1+i] > 1) + Mems[data1+i] = 0 + } + call pmplps (pmi, v, Mems[data1], 0, nc, PIX_SRC) + } + + # Set the interpolation. + fp = yt_fpinit (pmi, 2, 3) + + # Merge back the bad pixels which are not interpolated. + v[1] = 1 + do j = 1, nl { + v[2] = j + call pmglps (pm, v, Mems[data1], 0, nc, PIX_SRC) + call pmglps (pmi, v, Mems[data2], 0, nc, PIX_SRC) + do i = 0, nc-1 { + if (Mems[data2+i] != 0) + Mems[data1+i] = Mems[data2+i] + else if (Mems[data1+i] > 1) + Mems[data1+i] = 6 + } + call pmplps (pm, v, Mems[data1], 0, nc, PIX_SRC) + } + + # Finish up. + call mfree (data1, TY_SHORT) + call mfree (data2, TY_SHORT) + #call pm_close (pmi) +end diff --git a/pkg/xtools/fixpix/xtfixpix.h b/pkg/xtools/fixpix/xtfixpix.h new file mode 100644 index 00000000..de30f65d --- /dev/null +++ b/pkg/xtools/fixpix/xtfixpix.h @@ -0,0 +1,24 @@ +# XT_FIXPIX data structure. +define FP_LEN 13 # Length of FP structure +define FP_PM Memi[$1] # Pixel mask pointer +define FP_LVAL Memi[$1+1] # Mask value for line interpolation +define FP_CVAL Memi[$1+2] # Mask value for column interpolation +define FP_NCOLS Memi[$1+3] # Number of columns to interpolate +define FP_PCOL Memi[$1+4] # Pointer to columns +define FP_PL1 Memi[$1+5] # Pointer to start lines +define FP_PL2 Memi[$1+6] # Pointer to end lines +define FP_PV1 Memi[$1+7] # Pointer to start values +define FP_PV2 Memi[$1+8] # Pointer to end values +define FP_LMIN Memi[$1+9] # Minimum line +define FP_LMAX Memi[$1+10] # Maximum line +define FP_PIXTYPE Memi[$1+11] # Pixel type for values +define FP_DATA Memi[$1+12] # Data values + +define FP_COL Memi[FP_PCOL($1)+$2-1] +define FP_L1 Memi[FP_PL1($1)+$2-1] +define FP_L2 Memi[FP_PL2($1)+$2-1] +define FP_V1 (FP_PV1($1)+$2-1) +define FP_V2 (FP_PV2($1)+$2-1) + +define FP_LDEF 1 # Default line interpolation code +define FP_CDEF 2 # Default column interpolation code diff --git a/pkg/xtools/fixpix/xtfixpix.x b/pkg/xtools/fixpix/xtfixpix.x new file mode 100644 index 00000000..500824b5 --- /dev/null +++ b/pkg/xtools/fixpix/xtfixpix.x @@ -0,0 +1,270 @@ +include <imhdr.h> +include <imset.h> +include <pmset.h> +include "xtfixpix.h" + + +# XT_FPINIT -- Initialize FIXPIX data structure. +# If the mask is null or empty a null pointer is returned. +# If the mask is not empty the mask is examined for bad pixels requiring +# column interpolation. The columns and interpolation endpoints are +# recorded. Note that line interpolation does not need to be mapped since +# this can be done efficiently as the reference image is accessed line by +# line. + +pointer procedure xt_fpinit (pm, lvalin, cvalin) + +pointer pm #I Pixel mask +int lvalin #I Input line interpolation code +int cvalin #I Input column interpolation code + +int i, j, k, l, n, nc, nl, l1, l2, lmin, lmax, ncols, lval, cval, ncompress +short val +long v[IM_MAXDIM] +pointer fp, ptr, col, pl1, pl2 +pointer sp, buf, cols + +bool pm_empty() +errchk pmglrs, pmplrs() + +begin + # Check for empty mask. + if (pm == NULL) + return (NULL) + if (pm_empty (pm)) + return (NULL) + + # Get mask size. + call pm_gsize (pm, i, v, j) + nc = v[1] + nl = v[2] + + # Allocate memory and data structure. + call smark (sp) + call salloc (buf, 3*max(nc, nl), TY_SHORT) + call salloc (cols, nc, TY_SHORT) + call calloc (fp, FP_LEN, TY_STRUCT) + + # Set the mask codes. Go through the mask and change any mask codes + # that match the input mask code to the output mask code (if they are + # different). This is done to move the mask codes to a range that + # won't conflict with the length values. For any other code replace + # the value by the length of the bad region along the line. This + # value will be used in comparison to the length along the column for + # setting the interpolation for the narrower dimension. + + if ((IS_INDEFI(lvalin)||lvalin<1) && (IS_INDEFI(cvalin)||cvalin<1)) { + lval = FP_LDEF + cval = FP_CDEF + } else if (IS_INDEFI(lvalin) || lvalin < 1) { + lval = FP_LDEF + cval = mod (cvalin - 1, nc) + 1 + if (lval == cval) + lval = FP_CDEF + } else if (IS_INDEFI(cvalin) || cvalin < 1) { + lval = mod (lvalin - 1, nc) + 1 + cval = FP_CDEF + if (cval == lval) + cval = FP_LDEF + } else if (lvalin != cvalin) { + lval = mod (lvalin - 1, nc) + 1 + cval = mod (cvalin - 1, nc) + 1 + } else { + call mfree (fp, TY_STRUCT) + call sfree (sp) + call error (1, "Interpolation codes cannot be the same") + } + call xt_fpsinterp (pm, nc, nl, v, Mems[buf], lvalin, cvalin, lval, cval) + + # Go through and check if there is any need for column interpolation; + # i.e. are there any mask values different from the line interpolation. + + call aclrs (Mems[cols], nc) + call amovkl (long(1), v, IM_MAXDIM) + do l = 1, nl { + v[2] = l + call pmglrs (pm, v, Mems[buf], 0, nc, 0) + ptr = buf + 3 + do i = 2, Mems[buf] { + val = Mems[ptr+2] + if (val != lval) { + val = 1 + n = Mems[ptr+1] + call amovks (val, Mems[cols+Mems[ptr]-1], n) + } + ptr = ptr + 3 + } + } + n = 0 + do i = 1, nc + if (Mems[cols+i-1] != 0) + n = n + 1 + + # If there are mask codes for either column interpolation or + # interpolation lengths along lines to compare against column + # interpolation check the interpolation length against the + # column and set the line interpolation endpoints to use. + # compute the minimum and maximum lines that are endpoints + # to restrict the random access pass that will be needed to + # get the endpoint values. + + if (n > 0) { + n = n + 10 + call malloc (col, n, TY_INT) + call malloc (pl1, n, TY_INT) + call malloc (pl2, n, TY_INT) + ncols = 0 + lmin = nl + lmax = 0 + ncompress = 0 + do i = 1, nc { + if (Mems[cols+i-1] == 0) + next + v[1] = i + do l = 1, nl { + v[2] = l + call pmglps (pm, v, Mems[buf+l-1], 0, 1, 0) + } + for (l1=1; l1<=nl && Mems[buf+l1-1]==0; l1=l1+1) + ; + while (l1 <= nl) { + l1 = l1 - 1 + for (l2=l1+1; l2<=nl && Mems[buf+l2-1]!=0; l2=l2+1) + ; + j = 0 + k = nc + l2 - l1 - 1 + do l = l1+1, l2-1 { + val = Mems[buf+l-1] + if (val == cval) + j = j + 1 + else if (val > nc) { + if (val > k) { + j = j + 1 + val = cval + } else + val = lval + v[2] = l + call pmplps (pm, v, val, 0, 1, PIX_SRC) + ncompress = ncompress + 1 + } + } + if (ncompress > 100) { + call pm_compress (pm) + ncompress = 0 + } + if (j > 0) { + if (ncols == n) { + n = n + 10 + call realloc (col, n, TY_INT) + call realloc (pl1, n, TY_INT) + call realloc (pl2, n, TY_INT) + } + j = 1 + l1 - 1 + k = 1 + l2 - 1 + lmin = min (lmin, j, k) + lmax = max (lmax, j, k) + Memi[col+ncols] = i + Memi[pl1+ncols] = j + Memi[pl2+ncols] = k + ncols = ncols + 1 + } + for (l1=l2+1; l1<=nl && Mems[buf+l1-1]==0; l1=l1+1) + ; + } + } + + FP_LMIN(fp) = lmin + FP_LMAX(fp) = lmax + FP_NCOLS(fp) = ncols + FP_PCOL(fp) = col + FP_PL1(fp) = pl1 + FP_PL2(fp) = pl2 + } + + FP_PM(fp) = pm + FP_LVAL(fp) = lval + FP_CVAL(fp) = cval + + call sfree (sp) + return (fp) +end + + +# XT_SINTERP -- Set length of line interpolation regions. +# The mask values are set to the length of any column interpolation +# plus an offset leaving any line and column interpolation codes +# unchanged. These values will be used in a second pass to compare +# to the lengths of line interpolation and then the mask values will +# be reset to one of the line or column interpolation codes based on +# the minimum distance. + +procedure xt_fpsinterp (pm, nc, nl, v, data, lvalin, cvalin, lvalout, cvalout) + +pointer pm #I Pixel mask +int nc, nl #I Mask size +long v[ARB] #I Coordinate vector +short data[ARB] #I Data buffer +int lvalin #I Input line interpolation code +int cvalin #I Input column interpolation code +int lvalout #I Output line interpolation code +int cvalout #I Output column interpolation code + +int c, l, c1, c2, val +bool pm_linenotempty() + +begin + call amovkl (long(1), v, IM_MAXDIM) + do l = 1, nl { + v[2] = l + if (!pm_linenotempty (pm, v)) + next + + call pmglps (pm, v, data, 0, nc, 0) + + for (c1=1; c1<=nc && data[c1]==0; c1=c1+1) + ; + while (c1 <= nc) { + for (c2=c1+1; c2<=nc && data[c2]!=0; c2=c2+1) + ; + c2 = c2 - 1 + do c = c1, c2 { + val = data[c] + if (val == lvalin) { + if (lvalin != lvalout) + data[c] = lvalout + } else if (val == cvalin) { + if (cvalin != cvalout) + data[c] = cvalout + } else { + data[c] = nc + c2 - c1 + 1 + } + } + for (c1=c2+2; c1<=nc && data[c1]==0; c1=c1+1) + ; + } + + call pmplps (pm, v, data, 0, nc, PIX_SRC) + } +end + + +# XT_FPFREE -- Free FIXPIX data structures. + +procedure xt_fpfree (fp) + +pointer fp #U FIXPIX data structure + +begin + if (fp == NULL) + return + call mfree (FP_PCOL(fp), TY_INT) + call mfree (FP_PL1(fp), TY_INT) + call mfree (FP_PL2(fp), TY_INT) + if (FP_PV1(fp) != NULL) + call mfree (FP_PV1(fp), FP_PIXTYPE(fp)) + if (FP_PV2(fp) != NULL) + call mfree (FP_PV2(fp), FP_PIXTYPE(fp)) + if (FP_DATA(fp) != NULL) + call mfree (FP_DATA(fp), FP_PIXTYPE(fp)) + call mfree (fp, TY_STRUCT) +end diff --git a/pkg/xtools/fixpix/xtfp.gx b/pkg/xtools/fixpix/xtfp.gx new file mode 100644 index 00000000..70893ff8 --- /dev/null +++ b/pkg/xtools/fixpix/xtfp.gx @@ -0,0 +1,275 @@ +include <imhdr.h> +include <pmset.h> +include "xtfixpix.h" + + +$for (silrd) + +# XT_FP -- Get the specified line of image data and replace bad pixels by +# interpolation. + +pointer procedure xt_fp$t (fp, im, line, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +pointer imgl2$t(), xt_fps$t() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2$t (im, line)) + + col1 = 1 + col2 = IM_LEN(im,1) + line1 = 1 + line2 = IM_LEN(im,2) + + return (xt_fps$t (fp, im, line, col1, col2, line1, line2, fd)) +end + + +# XT_FXS -- Get the specified line of image data and replace bad pixels by +# interpolation within a specified section. + +pointer procedure xt_fps$t (fp, im, line, col1, col2, line1, line2, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 +long v[IM_MAXDIM] +$if (datatype == silr) +real a, b, c, d, val +$else +PIXEL a, b, c, d, val +$endif +PIXEL indef +pointer pm, data, bp + +bool pm_linenotempty() +pointer imgl2$t(), xt_fpval$t() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2$t (im, line)) + + # Initialize + pm = FP_PM(fp) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + ncols = FP_NCOLS(fp) + call amovkl (long(1), v, IM_MAXDIM) + v[2] = line + + # If there might be column interpolation initialize value arrays. + if (ncols > 0 && FP_PV1(fp) == NULL) { + FP_PIXTYPE(fp) = TY_PIXEL + call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) + call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) + indef = INDEF + call amovk$t (indef, Mem$t[FP_V1(fp,1)], ncols) + call amovk$t (indef, Mem$t[FP_V2(fp,1)], ncols) + } + + # If there are no bad pixels in the line and the line contains + # no column interpolation endpoints return the data directly. + # Otherwise get the line and fill in any endpoints that may + # be used later. + + if (!pm_linenotempty (pm, v)) { + if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) + return (imgl2$t (im, line)) + else + return (xt_fpval$t (fp, im, line)) + } + + # Get the pixel mask. + call malloc (bp, nc, TY_SHORT) + call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) + bp = bp - 1 + + # Check if any column interpolation endpoints are needed and + # set them. Set any other endpoints on the same lines at + # the same time. + + if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { + j = 1 + do i = col1, col2 { + if (Mems[bp+i] == FP_CVAL(fp)) { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + if (line>FP_L1(fp,j) && line<FP_L2(fp,j)) { + if (IS_INDEF(Mem$t[FP_V1(fp,j)])) + data = xt_fpval$t (fp, im, FP_L1(fp,j)) + if (IS_INDEF(Mem$t[FP_V2(fp,j)])) + data = xt_fpval$t (fp, im, FP_L2(fp,j)) + } + } + } + } + } + + # Fix pixels by column or line interpolation. + if (FP_DATA(fp) == NULL) { + FP_PIXTYPE(fp) = TY_PIXEL + call malloc (FP_DATA(fp), nc, FP_PIXTYPE(fp)) + } + data = FP_DATA(fp) + call amov$t (Mem$t[xt_fpval$t(fp,im,line)], Mem$t[data], nc) + j = 1 + for (c1=col1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + while (c1 <= col2) { + c1 = c1 - 1 + for (c2=c1+2; c2<=col2 && Mems[bp+c2]!=0; c2=c2+1) + ; + a = INDEF + do i = c1+1, c2-1 { + if (Mems[bp+i] == FP_LVAL(fp)) { + if (IS_INDEF(a)) { + if (c1 < col1 && c2 > col2) { + c1 = c2 + 1 + next + } + if (c1 >= col1) + a = Mem$t[data+c1-1] + else + a = Mem$t[data+c2-1] + if (c2 <= col2) + b = (Mem$t[data+c2-1] - a) / (c2 - c1) + else + b = 0. + } + val = a + b * (i - c1) + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call parg$t (Mem$t[data+i-1]) + $if (datatype == silr) + call pargr (val) + $else + call parg$t (val) + $endif + if (c1 >= col1) { + call fprintf (fd, " %4d %4d") + call pargi (c1) + call pargi (line) + } + if (c2 <= col2) { + call fprintf (fd, " %4d %4d") + call pargi (c2) + call pargi (line) + } + call fprintf (fd, "\n") + } + } else { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + l1 = FP_L1(fp,j) + l2 = FP_L2(fp,j) + if (l1 < line1 && l2 > line2) + next + if (line > l1 && line < l2) { + if (l1 >= line1) + c = Mem$t[FP_V1(fp,j)] + else + c = Mem$t[FP_V2(fp,j)] + if (l2 <= line2) { + d = (Mem$t[FP_V2(fp,j)] - c) / (l2 - l1) + val = c + d * (line - l1) + } else + val = c + l3 = l1 + l4 = l2 + } + } + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call parg$t (Mem$t[data+i-1]) + $if (datatype == silr) + call pargr (val) + $else + call parg$t (val) + $endif + if (l1 >= line1) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l3) + } + if (l2 <= line2) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l4) + } + call fprintf (fd, "\n") + } + } + $if (datatype == sil) + Mem$t[data+i-1] = nint (val) + $else + Mem$t[data+i-1] = val + $endif + } + for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + } + + call mfree (bp, TY_SHORT) + return (data) +end + + +# XT_FPVAL -- Get data for the specified line and set the values for +# all column interpolation endpoints which occur at that line. + +pointer procedure xt_fpval$t (fp, im, line) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line + +int i +pointer data, imgl2$t() + +begin + # Set out of bounds values to 0. These are not used but we need + # to cancel the INDEF values. + if (line < 1 || line > IM_LEN(im,2)) { + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Mem$t[FP_V1(fp,i)] = 0. + else if (line == FP_L2(fp,i)) + Mem$t[FP_V2(fp,i)] = 0. + } + return (NULL) + } + + data = imgl2$t (im, line) + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Mem$t[FP_V1(fp,i)] = Mem$t[data+FP_COL(fp,i)-1] + else if (line == FP_L2(fp,i)) + Mem$t[FP_V2(fp,i)] = Mem$t[data+FP_COL(fp,i)-1] + } + + return (data) +end + +$endfor diff --git a/pkg/xtools/fixpix/xtfp.x b/pkg/xtools/fixpix/xtfp.x new file mode 100644 index 00000000..774ffa12 --- /dev/null +++ b/pkg/xtools/fixpix/xtfp.x @@ -0,0 +1,1271 @@ +include <imhdr.h> +include <pmset.h> +include "xtfixpix.h" + + + + +# XT_FP -- Get the specified line of image data and replace bad pixels by +# interpolation. + +pointer procedure xt_fps (fp, im, line, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +pointer imgl2s(), xt_fpss() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2s (im, line)) + + col1 = 1 + col2 = IM_LEN(im,1) + line1 = 1 + line2 = IM_LEN(im,2) + + return (xt_fpss (fp, im, line, col1, col2, line1, line2, fd)) +end + + +# XT_FXS -- Get the specified line of image data and replace bad pixels by +# interpolation within a specified section. + +pointer procedure xt_fpss (fp, im, line, col1, col2, line1, line2, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 +long v[IM_MAXDIM] +real a, b, c, d, val +short indef +pointer pm, data, bp + +bool pm_linenotempty() +pointer imgl2s(), xt_fpvals() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2s (im, line)) + + # Initialize + pm = FP_PM(fp) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + ncols = FP_NCOLS(fp) + call amovkl (long(1), v, IM_MAXDIM) + v[2] = line + + # If there might be column interpolation initialize value arrays. + if (ncols > 0 && FP_PV1(fp) == NULL) { + FP_PIXTYPE(fp) = TY_SHORT + call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) + call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) + indef = INDEFS + call amovks (indef, Mems[FP_V1(fp,1)], ncols) + call amovks (indef, Mems[FP_V2(fp,1)], ncols) + } + + # If there are no bad pixels in the line and the line contains + # no column interpolation endpoints return the data directly. + # Otherwise get the line and fill in any endpoints that may + # be used later. + + if (!pm_linenotempty (pm, v)) { + if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) + return (imgl2s (im, line)) + else + return (xt_fpvals (fp, im, line)) + } + + # Get the pixel mask. + call malloc (bp, nc, TY_SHORT) + call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) + bp = bp - 1 + + # Check if any column interpolation endpoints are needed and + # set them. Set any other endpoints on the same lines at + # the same time. + + if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { + j = 1 + do i = col1, col2 { + if (Mems[bp+i] == FP_CVAL(fp)) { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + if (line>FP_L1(fp,j) && line<FP_L2(fp,j)) { + if (IS_INDEFS(Mems[FP_V1(fp,j)])) + data = xt_fpvals (fp, im, FP_L1(fp,j)) + if (IS_INDEFS(Mems[FP_V2(fp,j)])) + data = xt_fpvals (fp, im, FP_L2(fp,j)) + } + } + } + } + } + + # Fix pixels by column or line interpolation. + if (FP_DATA(fp) == NULL) { + FP_PIXTYPE(fp) = TY_SHORT + call malloc (FP_DATA(fp), nc, FP_PIXTYPE(fp)) + } + data = FP_DATA(fp) + call amovs (Mems[xt_fpvals(fp,im,line)], Mems[data], nc) + j = 1 + for (c1=col1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + while (c1 <= col2) { + c1 = c1 - 1 + for (c2=c1+2; c2<=col2 && Mems[bp+c2]!=0; c2=c2+1) + ; + a = INDEFS + do i = c1+1, c2-1 { + if (Mems[bp+i] == FP_LVAL(fp)) { + if (IS_INDEFS(a)) { + if (c1 < col1 && c2 > col2) { + c1 = c2 + 1 + next + } + if (c1 >= col1) + a = Mems[data+c1-1] + else + a = Mems[data+c2-1] + if (c2 <= col2) + b = (Mems[data+c2-1] - a) / (c2 - c1) + else + b = 0. + } + val = a + b * (i - c1) + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call pargs (Mems[data+i-1]) + call pargr (val) + if (c1 >= col1) { + call fprintf (fd, " %4d %4d") + call pargi (c1) + call pargi (line) + } + if (c2 <= col2) { + call fprintf (fd, " %4d %4d") + call pargi (c2) + call pargi (line) + } + call fprintf (fd, "\n") + } + } else { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + l1 = FP_L1(fp,j) + l2 = FP_L2(fp,j) + if (l1 < line1 && l2 > line2) + next + if (line > l1 && line < l2) { + if (l1 >= line1) + c = Mems[FP_V1(fp,j)] + else + c = Mems[FP_V2(fp,j)] + if (l2 <= line2) { + d = (Mems[FP_V2(fp,j)] - c) / (l2 - l1) + val = c + d * (line - l1) + } else + val = c + l3 = l1 + l4 = l2 + } + } + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call pargs (Mems[data+i-1]) + call pargr (val) + if (l1 >= line1) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l3) + } + if (l2 <= line2) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l4) + } + call fprintf (fd, "\n") + } + } + Mems[data+i-1] = nint (val) + } + for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + } + + call mfree (bp, TY_SHORT) + return (data) +end + + +# XT_FPVAL -- Get data for the specified line and set the values for +# all column interpolation endpoints which occur at that line. + +pointer procedure xt_fpvals (fp, im, line) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line + +int i +pointer data, imgl2s() + +begin + # Set out of bounds values to 0. These are not used but we need + # to cancel the INDEF values. + if (line < 1 || line > IM_LEN(im,2)) { + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Mems[FP_V1(fp,i)] = 0. + else if (line == FP_L2(fp,i)) + Mems[FP_V2(fp,i)] = 0. + } + return (NULL) + } + + data = imgl2s (im, line) + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Mems[FP_V1(fp,i)] = Mems[data+FP_COL(fp,i)-1] + else if (line == FP_L2(fp,i)) + Mems[FP_V2(fp,i)] = Mems[data+FP_COL(fp,i)-1] + } + + return (data) +end + + + +# XT_FP -- Get the specified line of image data and replace bad pixels by +# interpolation. + +pointer procedure xt_fpi (fp, im, line, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +pointer imgl2i(), xt_fpsi() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2i (im, line)) + + col1 = 1 + col2 = IM_LEN(im,1) + line1 = 1 + line2 = IM_LEN(im,2) + + return (xt_fpsi (fp, im, line, col1, col2, line1, line2, fd)) +end + + +# XT_FXS -- Get the specified line of image data and replace bad pixels by +# interpolation within a specified section. + +pointer procedure xt_fpsi (fp, im, line, col1, col2, line1, line2, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 +long v[IM_MAXDIM] +real a, b, c, d, val +int indef +pointer pm, data, bp + +bool pm_linenotempty() +pointer imgl2i(), xt_fpvali() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2i (im, line)) + + # Initialize + pm = FP_PM(fp) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + ncols = FP_NCOLS(fp) + call amovkl (long(1), v, IM_MAXDIM) + v[2] = line + + # If there might be column interpolation initialize value arrays. + if (ncols > 0 && FP_PV1(fp) == NULL) { + FP_PIXTYPE(fp) = TY_INT + call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) + call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) + indef = INDEFI + call amovki (indef, Memi[FP_V1(fp,1)], ncols) + call amovki (indef, Memi[FP_V2(fp,1)], ncols) + } + + # If there are no bad pixels in the line and the line contains + # no column interpolation endpoints return the data directly. + # Otherwise get the line and fill in any endpoints that may + # be used later. + + if (!pm_linenotempty (pm, v)) { + if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) + return (imgl2i (im, line)) + else + return (xt_fpvali (fp, im, line)) + } + + # Get the pixel mask. + call malloc (bp, nc, TY_SHORT) + call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) + bp = bp - 1 + + # Check if any column interpolation endpoints are needed and + # set them. Set any other endpoints on the same lines at + # the same time. + + if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { + j = 1 + do i = col1, col2 { + if (Mems[bp+i] == FP_CVAL(fp)) { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + if (line>FP_L1(fp,j) && line<FP_L2(fp,j)) { + if (IS_INDEFI(Memi[FP_V1(fp,j)])) + data = xt_fpvali (fp, im, FP_L1(fp,j)) + if (IS_INDEFI(Memi[FP_V2(fp,j)])) + data = xt_fpvali (fp, im, FP_L2(fp,j)) + } + } + } + } + } + + # Fix pixels by column or line interpolation. + if (FP_DATA(fp) == NULL) { + FP_PIXTYPE(fp) = TY_INT + call malloc (FP_DATA(fp), nc, FP_PIXTYPE(fp)) + } + data = FP_DATA(fp) + call amovi (Memi[xt_fpvali(fp,im,line)], Memi[data], nc) + j = 1 + for (c1=col1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + while (c1 <= col2) { + c1 = c1 - 1 + for (c2=c1+2; c2<=col2 && Mems[bp+c2]!=0; c2=c2+1) + ; + a = INDEFI + do i = c1+1, c2-1 { + if (Mems[bp+i] == FP_LVAL(fp)) { + if (IS_INDEFI(a)) { + if (c1 < col1 && c2 > col2) { + c1 = c2 + 1 + next + } + if (c1 >= col1) + a = Memi[data+c1-1] + else + a = Memi[data+c2-1] + if (c2 <= col2) + b = (Memi[data+c2-1] - a) / (c2 - c1) + else + b = 0. + } + val = a + b * (i - c1) + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call pargi (Memi[data+i-1]) + call pargr (val) + if (c1 >= col1) { + call fprintf (fd, " %4d %4d") + call pargi (c1) + call pargi (line) + } + if (c2 <= col2) { + call fprintf (fd, " %4d %4d") + call pargi (c2) + call pargi (line) + } + call fprintf (fd, "\n") + } + } else { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + l1 = FP_L1(fp,j) + l2 = FP_L2(fp,j) + if (l1 < line1 && l2 > line2) + next + if (line > l1 && line < l2) { + if (l1 >= line1) + c = Memi[FP_V1(fp,j)] + else + c = Memi[FP_V2(fp,j)] + if (l2 <= line2) { + d = (Memi[FP_V2(fp,j)] - c) / (l2 - l1) + val = c + d * (line - l1) + } else + val = c + l3 = l1 + l4 = l2 + } + } + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call pargi (Memi[data+i-1]) + call pargr (val) + if (l1 >= line1) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l3) + } + if (l2 <= line2) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l4) + } + call fprintf (fd, "\n") + } + } + Memi[data+i-1] = nint (val) + } + for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + } + + call mfree (bp, TY_SHORT) + return (data) +end + + +# XT_FPVAL -- Get data for the specified line and set the values for +# all column interpolation endpoints which occur at that line. + +pointer procedure xt_fpvali (fp, im, line) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line + +int i +pointer data, imgl2i() + +begin + # Set out of bounds values to 0. These are not used but we need + # to cancel the INDEF values. + if (line < 1 || line > IM_LEN(im,2)) { + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Memi[FP_V1(fp,i)] = 0. + else if (line == FP_L2(fp,i)) + Memi[FP_V2(fp,i)] = 0. + } + return (NULL) + } + + data = imgl2i (im, line) + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Memi[FP_V1(fp,i)] = Memi[data+FP_COL(fp,i)-1] + else if (line == FP_L2(fp,i)) + Memi[FP_V2(fp,i)] = Memi[data+FP_COL(fp,i)-1] + } + + return (data) +end + + + +# XT_FP -- Get the specified line of image data and replace bad pixels by +# interpolation. + +pointer procedure xt_fpl (fp, im, line, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +pointer imgl2l(), xt_fpsl() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2l (im, line)) + + col1 = 1 + col2 = IM_LEN(im,1) + line1 = 1 + line2 = IM_LEN(im,2) + + return (xt_fpsl (fp, im, line, col1, col2, line1, line2, fd)) +end + + +# XT_FXS -- Get the specified line of image data and replace bad pixels by +# interpolation within a specified section. + +pointer procedure xt_fpsl (fp, im, line, col1, col2, line1, line2, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 +long v[IM_MAXDIM] +real a, b, c, d, val +long indef +pointer pm, data, bp + +bool pm_linenotempty() +pointer imgl2l(), xt_fpvall() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2l (im, line)) + + # Initialize + pm = FP_PM(fp) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + ncols = FP_NCOLS(fp) + call amovkl (long(1), v, IM_MAXDIM) + v[2] = line + + # If there might be column interpolation initialize value arrays. + if (ncols > 0 && FP_PV1(fp) == NULL) { + FP_PIXTYPE(fp) = TY_LONG + call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) + call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) + indef = INDEFL + call amovkl (indef, Meml[FP_V1(fp,1)], ncols) + call amovkl (indef, Meml[FP_V2(fp,1)], ncols) + } + + # If there are no bad pixels in the line and the line contains + # no column interpolation endpoints return the data directly. + # Otherwise get the line and fill in any endpoints that may + # be used later. + + if (!pm_linenotempty (pm, v)) { + if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) + return (imgl2l (im, line)) + else + return (xt_fpvall (fp, im, line)) + } + + # Get the pixel mask. + call malloc (bp, nc, TY_SHORT) + call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) + bp = bp - 1 + + # Check if any column interpolation endpoints are needed and + # set them. Set any other endpoints on the same lines at + # the same time. + + if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { + j = 1 + do i = col1, col2 { + if (Mems[bp+i] == FP_CVAL(fp)) { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + if (line>FP_L1(fp,j) && line<FP_L2(fp,j)) { + if (IS_INDEFL(Meml[FP_V1(fp,j)])) + data = xt_fpvall (fp, im, FP_L1(fp,j)) + if (IS_INDEFL(Meml[FP_V2(fp,j)])) + data = xt_fpvall (fp, im, FP_L2(fp,j)) + } + } + } + } + } + + # Fix pixels by column or line interpolation. + if (FP_DATA(fp) == NULL) { + FP_PIXTYPE(fp) = TY_LONG + call malloc (FP_DATA(fp), nc, FP_PIXTYPE(fp)) + } + data = FP_DATA(fp) + call amovl (Meml[xt_fpvall(fp,im,line)], Meml[data], nc) + j = 1 + for (c1=col1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + while (c1 <= col2) { + c1 = c1 - 1 + for (c2=c1+2; c2<=col2 && Mems[bp+c2]!=0; c2=c2+1) + ; + a = INDEFL + do i = c1+1, c2-1 { + if (Mems[bp+i] == FP_LVAL(fp)) { + if (IS_INDEFL(a)) { + if (c1 < col1 && c2 > col2) { + c1 = c2 + 1 + next + } + if (c1 >= col1) + a = Meml[data+c1-1] + else + a = Meml[data+c2-1] + if (c2 <= col2) + b = (Meml[data+c2-1] - a) / (c2 - c1) + else + b = 0. + } + val = a + b * (i - c1) + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call pargl (Meml[data+i-1]) + call pargr (val) + if (c1 >= col1) { + call fprintf (fd, " %4d %4d") + call pargi (c1) + call pargi (line) + } + if (c2 <= col2) { + call fprintf (fd, " %4d %4d") + call pargi (c2) + call pargi (line) + } + call fprintf (fd, "\n") + } + } else { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + l1 = FP_L1(fp,j) + l2 = FP_L2(fp,j) + if (l1 < line1 && l2 > line2) + next + if (line > l1 && line < l2) { + if (l1 >= line1) + c = Meml[FP_V1(fp,j)] + else + c = Meml[FP_V2(fp,j)] + if (l2 <= line2) { + d = (Meml[FP_V2(fp,j)] - c) / (l2 - l1) + val = c + d * (line - l1) + } else + val = c + l3 = l1 + l4 = l2 + } + } + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call pargl (Meml[data+i-1]) + call pargr (val) + if (l1 >= line1) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l3) + } + if (l2 <= line2) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l4) + } + call fprintf (fd, "\n") + } + } + Meml[data+i-1] = nint (val) + } + for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + } + + call mfree (bp, TY_SHORT) + return (data) +end + + +# XT_FPVAL -- Get data for the specified line and set the values for +# all column interpolation endpoints which occur at that line. + +pointer procedure xt_fpvall (fp, im, line) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line + +int i +pointer data, imgl2l() + +begin + # Set out of bounds values to 0. These are not used but we need + # to cancel the INDEF values. + if (line < 1 || line > IM_LEN(im,2)) { + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Meml[FP_V1(fp,i)] = 0. + else if (line == FP_L2(fp,i)) + Meml[FP_V2(fp,i)] = 0. + } + return (NULL) + } + + data = imgl2l (im, line) + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Meml[FP_V1(fp,i)] = Meml[data+FP_COL(fp,i)-1] + else if (line == FP_L2(fp,i)) + Meml[FP_V2(fp,i)] = Meml[data+FP_COL(fp,i)-1] + } + + return (data) +end + + + +# XT_FP -- Get the specified line of image data and replace bad pixels by +# interpolation. + +pointer procedure xt_fpr (fp, im, line, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +pointer imgl2r(), xt_fpsr() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2r (im, line)) + + col1 = 1 + col2 = IM_LEN(im,1) + line1 = 1 + line2 = IM_LEN(im,2) + + return (xt_fpsr (fp, im, line, col1, col2, line1, line2, fd)) +end + + +# XT_FXS -- Get the specified line of image data and replace bad pixels by +# interpolation within a specified section. + +pointer procedure xt_fpsr (fp, im, line, col1, col2, line1, line2, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 +long v[IM_MAXDIM] +real a, b, c, d, val +real indef +pointer pm, data, bp + +bool pm_linenotempty() +pointer imgl2r(), xt_fpvalr() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2r (im, line)) + + # Initialize + pm = FP_PM(fp) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + ncols = FP_NCOLS(fp) + call amovkl (long(1), v, IM_MAXDIM) + v[2] = line + + # If there might be column interpolation initialize value arrays. + if (ncols > 0 && FP_PV1(fp) == NULL) { + FP_PIXTYPE(fp) = TY_REAL + call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) + call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) + indef = INDEFR + call amovkr (indef, Memr[FP_V1(fp,1)], ncols) + call amovkr (indef, Memr[FP_V2(fp,1)], ncols) + } + + # If there are no bad pixels in the line and the line contains + # no column interpolation endpoints return the data directly. + # Otherwise get the line and fill in any endpoints that may + # be used later. + + if (!pm_linenotempty (pm, v)) { + if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) + return (imgl2r (im, line)) + else + return (xt_fpvalr (fp, im, line)) + } + + # Get the pixel mask. + call malloc (bp, nc, TY_SHORT) + call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) + bp = bp - 1 + + # Check if any column interpolation endpoints are needed and + # set them. Set any other endpoints on the same lines at + # the same time. + + if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { + j = 1 + do i = col1, col2 { + if (Mems[bp+i] == FP_CVAL(fp)) { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + if (line>FP_L1(fp,j) && line<FP_L2(fp,j)) { + if (IS_INDEFR(Memr[FP_V1(fp,j)])) + data = xt_fpvalr (fp, im, FP_L1(fp,j)) + if (IS_INDEFR(Memr[FP_V2(fp,j)])) + data = xt_fpvalr (fp, im, FP_L2(fp,j)) + } + } + } + } + } + + # Fix pixels by column or line interpolation. + if (FP_DATA(fp) == NULL) { + FP_PIXTYPE(fp) = TY_REAL + call malloc (FP_DATA(fp), nc, FP_PIXTYPE(fp)) + } + data = FP_DATA(fp) + call amovr (Memr[xt_fpvalr(fp,im,line)], Memr[data], nc) + j = 1 + for (c1=col1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + while (c1 <= col2) { + c1 = c1 - 1 + for (c2=c1+2; c2<=col2 && Mems[bp+c2]!=0; c2=c2+1) + ; + a = INDEFR + do i = c1+1, c2-1 { + if (Mems[bp+i] == FP_LVAL(fp)) { + if (IS_INDEFR(a)) { + if (c1 < col1 && c2 > col2) { + c1 = c2 + 1 + next + } + if (c1 >= col1) + a = Memr[data+c1-1] + else + a = Memr[data+c2-1] + if (c2 <= col2) + b = (Memr[data+c2-1] - a) / (c2 - c1) + else + b = 0. + } + val = a + b * (i - c1) + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call pargr (Memr[data+i-1]) + call pargr (val) + if (c1 >= col1) { + call fprintf (fd, " %4d %4d") + call pargi (c1) + call pargi (line) + } + if (c2 <= col2) { + call fprintf (fd, " %4d %4d") + call pargi (c2) + call pargi (line) + } + call fprintf (fd, "\n") + } + } else { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + l1 = FP_L1(fp,j) + l2 = FP_L2(fp,j) + if (l1 < line1 && l2 > line2) + next + if (line > l1 && line < l2) { + if (l1 >= line1) + c = Memr[FP_V1(fp,j)] + else + c = Memr[FP_V2(fp,j)] + if (l2 <= line2) { + d = (Memr[FP_V2(fp,j)] - c) / (l2 - l1) + val = c + d * (line - l1) + } else + val = c + l3 = l1 + l4 = l2 + } + } + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call pargr (Memr[data+i-1]) + call pargr (val) + if (l1 >= line1) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l3) + } + if (l2 <= line2) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l4) + } + call fprintf (fd, "\n") + } + } + Memr[data+i-1] = val + } + for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + } + + call mfree (bp, TY_SHORT) + return (data) +end + + +# XT_FPVAL -- Get data for the specified line and set the values for +# all column interpolation endpoints which occur at that line. + +pointer procedure xt_fpvalr (fp, im, line) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line + +int i +pointer data, imgl2r() + +begin + # Set out of bounds values to 0. These are not used but we need + # to cancel the INDEF values. + if (line < 1 || line > IM_LEN(im,2)) { + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Memr[FP_V1(fp,i)] = 0. + else if (line == FP_L2(fp,i)) + Memr[FP_V2(fp,i)] = 0. + } + return (NULL) + } + + data = imgl2r (im, line) + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Memr[FP_V1(fp,i)] = Memr[data+FP_COL(fp,i)-1] + else if (line == FP_L2(fp,i)) + Memr[FP_V2(fp,i)] = Memr[data+FP_COL(fp,i)-1] + } + + return (data) +end + + + +# XT_FP -- Get the specified line of image data and replace bad pixels by +# interpolation. + +pointer procedure xt_fpd (fp, im, line, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +pointer imgl2d(), xt_fpsd() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2d (im, line)) + + col1 = 1 + col2 = IM_LEN(im,1) + line1 = 1 + line2 = IM_LEN(im,2) + + return (xt_fpsd (fp, im, line, col1, col2, line1, line2, fd)) +end + + +# XT_FXS -- Get the specified line of image data and replace bad pixels by +# interpolation within a specified section. + +pointer procedure xt_fpsd (fp, im, line, col1, col2, line1, line2, fd) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line +int fd #I File descriptor for pixel list + +int col1, col2 #I Section of interest +int line1, line2 #I Section of interest + +int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 +long v[IM_MAXDIM] +double a, b, c, d, val +double indef +pointer pm, data, bp + +bool pm_linenotempty() +pointer imgl2d(), xt_fpvald() + +begin + # If there are no bad pixels just get the image line and return. + if (fp == NULL) + return (imgl2d (im, line)) + + # Initialize + pm = FP_PM(fp) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + ncols = FP_NCOLS(fp) + call amovkl (long(1), v, IM_MAXDIM) + v[2] = line + + # If there might be column interpolation initialize value arrays. + if (ncols > 0 && FP_PV1(fp) == NULL) { + FP_PIXTYPE(fp) = TY_DOUBLE + call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) + call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) + indef = INDEFD + call amovkd (indef, Memd[FP_V1(fp,1)], ncols) + call amovkd (indef, Memd[FP_V2(fp,1)], ncols) + } + + # If there are no bad pixels in the line and the line contains + # no column interpolation endpoints return the data directly. + # Otherwise get the line and fill in any endpoints that may + # be used later. + + if (!pm_linenotempty (pm, v)) { + if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) + return (imgl2d (im, line)) + else + return (xt_fpvald (fp, im, line)) + } + + # Get the pixel mask. + call malloc (bp, nc, TY_SHORT) + call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) + bp = bp - 1 + + # Check if any column interpolation endpoints are needed and + # set them. Set any other endpoints on the same lines at + # the same time. + + if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { + j = 1 + do i = col1, col2 { + if (Mems[bp+i] == FP_CVAL(fp)) { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + if (line>FP_L1(fp,j) && line<FP_L2(fp,j)) { + if (IS_INDEFD(Memd[FP_V1(fp,j)])) + data = xt_fpvald (fp, im, FP_L1(fp,j)) + if (IS_INDEFD(Memd[FP_V2(fp,j)])) + data = xt_fpvald (fp, im, FP_L2(fp,j)) + } + } + } + } + } + + # Fix pixels by column or line interpolation. + if (FP_DATA(fp) == NULL) { + FP_PIXTYPE(fp) = TY_DOUBLE + call malloc (FP_DATA(fp), nc, FP_PIXTYPE(fp)) + } + data = FP_DATA(fp) + call amovd (Memd[xt_fpvald(fp,im,line)], Memd[data], nc) + j = 1 + for (c1=col1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + while (c1 <= col2) { + c1 = c1 - 1 + for (c2=c1+2; c2<=col2 && Mems[bp+c2]!=0; c2=c2+1) + ; + a = INDEFD + do i = c1+1, c2-1 { + if (Mems[bp+i] == FP_LVAL(fp)) { + if (IS_INDEFD(a)) { + if (c1 < col1 && c2 > col2) { + c1 = c2 + 1 + next + } + if (c1 >= col1) + a = Memd[data+c1-1] + else + a = Memd[data+c2-1] + if (c2 <= col2) + b = (Memd[data+c2-1] - a) / (c2 - c1) + else + b = 0. + } + val = a + b * (i - c1) + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call pargd (Memd[data+i-1]) + call pargd (val) + if (c1 >= col1) { + call fprintf (fd, " %4d %4d") + call pargi (c1) + call pargi (line) + } + if (c2 <= col2) { + call fprintf (fd, " %4d %4d") + call pargi (c2) + call pargi (line) + } + call fprintf (fd, "\n") + } + } else { + for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) + ; + for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { + l1 = FP_L1(fp,j) + l2 = FP_L2(fp,j) + if (l1 < line1 && l2 > line2) + next + if (line > l1 && line < l2) { + if (l1 >= line1) + c = Memd[FP_V1(fp,j)] + else + c = Memd[FP_V2(fp,j)] + if (l2 <= line2) { + d = (Memd[FP_V2(fp,j)] - c) / (l2 - l1) + val = c + d * (line - l1) + } else + val = c + l3 = l1 + l4 = l2 + } + } + if (fd != NULL) { + call fprintf (fd, "%4d %4d %8g %8g") + call pargi (i) + call pargi (line) + call pargd (Memd[data+i-1]) + call pargd (val) + if (l1 >= line1) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l3) + } + if (l2 <= line2) { + call fprintf (fd, " %4d %4d") + call pargi (i) + call pargi (l4) + } + call fprintf (fd, "\n") + } + } + Memd[data+i-1] = val + } + for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) + ; + } + + call mfree (bp, TY_SHORT) + return (data) +end + + +# XT_FPVAL -- Get data for the specified line and set the values for +# all column interpolation endpoints which occur at that line. + +pointer procedure xt_fpvald (fp, im, line) + +pointer fp #I FIXPIX pointer +pointer im #I Image pointer +int line #I Line + +int i +pointer data, imgl2d() + +begin + # Set out of bounds values to 0. These are not used but we need + # to cancel the INDEF values. + if (line < 1 || line > IM_LEN(im,2)) { + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Memd[FP_V1(fp,i)] = 0. + else if (line == FP_L2(fp,i)) + Memd[FP_V2(fp,i)] = 0. + } + return (NULL) + } + + data = imgl2d (im, line) + do i = 1, FP_NCOLS(fp) { + if (line == FP_L1(fp,i)) + Memd[FP_V1(fp,i)] = Memd[data+FP_COL(fp,i)-1] + else if (line == FP_L2(fp,i)) + Memd[FP_V2(fp,i)] = Memd[data+FP_COL(fp,i)-1] + } + + return (data) +end + + diff --git a/pkg/xtools/fixpix/xtpmmap.x b/pkg/xtools/fixpix/xtpmmap.x new file mode 100644 index 00000000..54bbf954 --- /dev/null +++ b/pkg/xtools/fixpix/xtpmmap.x @@ -0,0 +1,693 @@ +include <mach.h> +include <ctype.h> +include <error.h> +include <imhdr.h> +include <imset.h> +include <pmset.h> +include <mwset.h> +include <syserr.h> + + +# XT_PMMAP -- Open a pixel mask READ_ONLY. +# +# This routine maps multiple types of mask files and designations. +# It matches the mask coordinates to the reference image based on the +# physical coordinate system so the mask may be of a different size. +# The mask name is returned so that the task has the name pointed to by "BPM". +# A null filename is allowed and returns NULL. + +pointer procedure xt_pmmap (pmname, refim, mname, sz_mname) + +char pmname[ARB] #I Pixel mask name +pointer refim #I Reference image pointer +char mname[ARB] #O Expanded mask name +int sz_mname #O Size of expanded mask name + +int i, flag, nowhite() +pointer sp, fname, im, ref, xt_pmmap1() +bool streq() +errchk xt_pmmap1 + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + im = NULL + i = nowhite (pmname, Memc[fname], SZ_FNAME) + if (Memc[fname] == '!') { + iferr (call imgstr (refim, Memc[fname+1], Memc[fname], SZ_FNAME)) + Memc[fname] = EOS + } else if (streq (Memc[fname], "BPM")) { + iferr (call imgstr (refim, "BPM", Memc[fname], SZ_FNAME)) + Memc[fname] = EOS + } else if (streq (Memc[fname], "^BPM")) { + flag = INVERT_MASK + iferr (call imgstr (refim, "BPM", Memc[fname+1], SZ_FNAME)) + Memc[fname] = EOS + } + + if (Memc[fname] == '^') { + flag = INVERT_MASK + call strcpy (Memc[fname+1], Memc[fname], SZ_FNAME) + } else + flag = NO + + if (streq (Memc[fname], "EMPTY")) + ref = refim + else + ref = NULL + + if (Memc[fname] != EOS) + im = xt_pmmap1 (Memc[fname], ref, refim, flag, YES) + call strcpy (Memc[fname], mname, sz_mname) + + call sfree (sp) + return (im) +end + + +# XT_MAPPM -- Open a pixel mask READ_ONLY with/without matching. +# +# This routine maps multiple types of mask files and designations. +# It may match the mask coordinates to the reference image based on the +# physical coordinate system. In either case the mask is matched to be +# the same size. The mask name is returned so that the task has the +# name pointed to by "BPM". A null filename is allowed and returns NULL. + +pointer procedure xt_mappm (pmname, refim, match, mname, sz_mname) + +char pmname[ARB] #I Pixel mask name +pointer refim #I Reference image pointer +int match #I Match by physical coordinates? +char mname[ARB] #O Expanded mask name +int sz_mname #O Size of expanded mask name + +int i, flag, nowhite() +pointer sp, fname, im, ref, xt_pmmap1() +bool streq() +errchk xt_pmmap1 + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + im = NULL + i = nowhite (pmname, Memc[fname], SZ_FNAME) + if (Memc[fname] == '!') { + iferr (call imgstr (refim, Memc[fname+1], Memc[fname], SZ_FNAME)) + Memc[fname] = EOS + } else if (streq (Memc[fname], "BPM")) { + iferr (call imgstr (refim, "BPM", Memc[fname], SZ_FNAME)) + Memc[fname] = EOS + } else if (streq (Memc[fname], "^BPM")) { + flag = INVERT_MASK + iferr (call imgstr (refim, "BPM", Memc[fname+1], SZ_FNAME)) + Memc[fname] = EOS + } + + if (Memc[fname] == '^') { + flag = INVERT_MASK + call strcpy (Memc[fname+1], Memc[fname], SZ_FNAME) + } else + flag = NO + + if (streq (Memc[fname], "EMPTY")) + ref = refim + else + ref = NULL + + if (Memc[fname] != EOS) + im = xt_pmmap1 (Memc[fname], ref, refim, flag, match) + call strcpy (Memc[fname], mname, sz_mname) + + call sfree (sp) + return (im) +end + + +# XT_PMUNMAP -- Unmap a mask image. +# Note that the imio pointer may be purely an internal pointer opened +# with im_pmmapo so we need to free the pl pointer explicitly. + +procedure xt_pmunmap (im) + +pointer im #I IMIO pointer for mask + +pointer pm +int imstati() + +begin + pm = imstati (im, IM_PMDES) + call pm_close (pm) + call imseti (im, IM_PMDES, NULL) + call imunmap (im) +end + + +# XT_PMMAP1 -- Open a pixel mask READ_ONLY. The input mask may be +# a pixel list image, a non-pixel list image, or a text file. +# Return error if the pixel mask cannot be opened. For pixel masks +# or image masks match the WCS. + +pointer procedure xt_pmmap1 (pmname, ref, refim, flag, match) + +char pmname[ARB] #I Pixel mask name +pointer ref #I Reference image for pixel mask +pointer refim #I Reference image for image or text +int flag #I Mask flag +int match #I Match by physical coordinates? + +int imstati(), errcode() +pointer im, pm +pointer im_pmmap(), xt_pmimmap(), xt_pmtext(), xt_pmsection() +bool streq() +errchk xt_match + +begin + im = NULL + + if (streq (pmname, "STDIN")) + im = xt_pmtext (pmname, refim, flag) + + else if (pmname[1] == '[') + im = xt_pmsection (pmname, refim, flag) + + else { + ifnoerr (im = im_pmmap (pmname, READ_ONLY, ref)) { + call xt_match (im, refim, match) + if (flag == INVERT_MASK) { + pm = imstati (im, IM_PMDES) + call xt_pminvert (pm) + call imseti (im, IM_PMDES, pm) + } + } else { + switch (errcode()) { + case SYS_IKIOPEN, SYS_FOPNNEXFIL, SYS_PLBADSAVEF, SYS_FOPEN: + ifnoerr (im = xt_pmimmap (pmname, refim, flag)) + call xt_match (im, refim, match) + else { + switch (errcode()) { + case SYS_IKIOPEN: + im = xt_pmtext (pmname, refim, flag) + default: + call erract (EA_ERROR) + } + } + default: + call erract (EA_ERROR) + } + } + } + + return (im) +end + + +# XT_PMIMMAP -- Open a pixel mask from a non-pixel list image. +# Return error if the image cannot be opened. + +pointer procedure xt_pmimmap (pmname, refim, flag) + +char pmname[ARB] #I Image name +pointer refim #I Reference image pointer +int flag #I Mask flag + +int i, ndim, npix, rop, val +pointer sp, v1, v2, im_in, im_out, pm, mw, data + +int imstati(), imgnli() +pointer immap(), pm_newmask(), im_pmmapo(), imgl1i(), mw_openim() +errchk immap, mw_openim, im_pmmapo + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + + im_in = immap (pmname, READ_ONLY, 0) + pm = imstati (im_in, IM_PMDES) + if (pm != NULL) + return (im_in) + pm = pm_newmask (im_in, 16) + + ndim = IM_NDIM(im_in) + npix = IM_LEN(im_in,1) + + if (flag == INVERT_MASK) + rop = PIX_NOT(PIX_SRC) + else + rop = PIX_SRC + + while (imgnli (im_in, data, Meml[v1]) != EOF) { + if (flag == INVERT_MASK) { + do i = 0, npix-1 { + val = Memi[data+i] + if (val <= 0) + Memi[data+i] = 1 + else + Memi[data+i] = 0 + } + } else { + do i = 0, npix-1 { + val = Memi[data+i] + if (val < 0) + Memi[data+i] = 0 + } + } + call pmplpi (pm, Meml[v2], Memi[data], 0, npix, rop) + call amovl (Meml[v1], Meml[v2], ndim) + } + + im_out = im_pmmapo (pm, im_in) + data = imgl1i (im_out) # Force I/O to set header + mw = mw_openim (im_in) # Set WCS + call mw_saveim (mw, im_out) + call mw_close (mw) + + #call imunmap (im_in) + call xt_pmunmap (im_in) + call sfree (sp) + return (im_out) +end + + +# XT_PMTEXT -- Create a pixel mask from a text file of rectangles. +# Return error if the file cannot be opened. +# This routine only applies to the first 2D plane. + +pointer procedure xt_pmtext (pmname, refim, flag) + +char pmname[ARB] #I Image name +pointer refim #I Reference image pointer +int flag #I Mask flag + +int fd, nc, nl, c1, c2, l1, l2, nc1, nl1, rop +pointer pm, im, mw, dummy + +int open(), fscan(), nscan() +pointer pm_newmask(), im_pmmapo(), imgl1i(), mw_openim() +errchk open, im_pmmapo + +begin + fd = open (pmname, READ_ONLY, TEXT_FILE) + pm = pm_newmask (refim, 16) + + nc = IM_LEN(refim,1) + nl = IM_LEN(refim,2) + + if (flag == INVERT_MASK) + call pl_box (pm, 1, 1, nc, nl, PIX_SET+PIX_VALUE(1)) + + while (fscan (fd) != EOF) { + call gargi (c1) + call gargi (c2) + call gargi (l1) + call gargi (l2) + if (nscan() != 4) { + if (nscan() == 2) { + l1 = c2 + c2 = c1 + l2 = l1 + } else + next + } + + c1 = max (1, c1) + c2 = min (nc, c2) + l1 = max (1, l1) + l2 = min (nl, l2) + nc1 = c2 - c1 + 1 + nl1 = l2 - l1 + 1 + if (nc1 < 1 || nl1 < 1) + next + + # Select mask value based on shape of rectangle. + if (flag == INVERT_MASK) + rop = PIX_CLR + else if (nc1 <= nl1) + rop = PIX_SET+PIX_VALUE(2) + else + rop = PIX_SET+PIX_VALUE(3) + + # Set mask rectangle. + call pm_box (pm, c1, l1, c2, l2, rop) + } + + call close (fd) + im = im_pmmapo (pm, refim) + dummy = imgl1i (im) # Force I/O to set header + mw = mw_openim (refim) # Set WCS + call mw_saveim (mw, im) + call mw_close (mw) + + return (im) +end + + +# XT_PMSECTION -- Create a pixel mask from an image section. +# This only applies the mask to the first plane of the image. + +pointer procedure xt_pmsection (section, refim, flag) + +char section[ARB] #I Image section +pointer refim #I Reference image pointer +int flag #I Mask flag + +int i, j, ip, temp, a[2], b[2], c[2], rop, ctoi() +pointer pm, im, mw, dummy, pm_newmask(), im_pmmapo(), imgl1i(), mw_openim() +errchk im_pmmapo +define error_ 99 + +begin + # This is currently only for 1D and 2D images. + if (IM_NDIM(refim) > 2) + call error (1, "Image sections only allowed for 1D and 2D images") + + # Decode the section string. + call amovki (1, a, 2) + call amovki (1, b, 2) + call amovki (1, c, 2) + do i = 1, IM_NDIM(refim) + b[i] = IM_LEN(refim,i) + + ip = 1 + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == '[') { + ip = ip + 1 + + do i = 1, IM_NDIM(refim) { + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get a:b:c. Allow notation such as "-*:c" + # (or even "-:c") where the step is obviously negative. + + if (ctoi (section, ip, temp) > 0) { # a + a[i] = temp + if (section[ip] == ':') { + ip = ip + 1 + if (ctoi (section, ip, b[i]) == 0) # a:b + goto error_ + } else + b[i] = a[i] + } else if (section[ip] == '-') { # -* + temp = a[i] + a[i] = b[i] + b[i] = temp + ip = ip + 1 + if (section[ip] == '*') + ip = ip + 1 + } else if (section[ip] == '*') # * + ip = ip + 1 + if (section[ip] == ':') { # ..:step + ip = ip + 1 + if (ctoi (section, ip, c[i]) == 0) + goto error_ + else if (c[i] == 0) + goto error_ + } + if (a[i] > b[i] && c[i] > 0) + c[i] = -c[i] + + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (i < IM_NDIM(refim)) { + if (section[ip] != ',') + goto error_ + } else { + if (section[ip] != ']') + goto error_ + } + ip = ip + 1 + } + } + + # In this case make the values be increasing only. + do i = 1, IM_NDIM(refim) + if (c[i] < 0) { + temp = a[i] + a[i] = b[i] + b[i] = temp + c[i] = -c[i] + } + + # Make the mask. + pm = pm_newmask (refim, 16) + + if (flag == INVERT_MASK) { + rop = PIX_SET+PIX_VALUE(1) + call pm_box (pm, 1, 1, IM_LEN(refim,1), IM_LEN(refim,2), rop) + rop = PIX_CLR + } else + rop = PIX_SET+PIX_VALUE(1) + + if (c[1] == 1 && c[2] == 1) + call pm_box (pm, a[1], a[2], b[1], b[2], rop) + + else if (c[1] == 1) + for (i=a[2]; i<=b[2]; i=i+c[2]) + call pm_box (pm, a[1], i, b[1], i, rop) + + else + for (i=a[2]; i<=b[2]; i=i+c[2]) + for (j=a[1]; j<=b[1]; j=j+c[1]) + call pm_point (pm, j, i, rop) + + im = im_pmmapo (pm, refim) + dummy = imgl1i (im) # Force I/O to set header + mw = mw_openim (refim) # Set WCS + call mw_saveim (mw, im) + call mw_close (mw) + + return (im) + +error_ + call error (1, "Error in image section specification") +end + + +# XT_PMINVERT -- Invert a pixel mask by changing 0 to 1 and non-zero to zero. + +procedure xt_pminvert (pm) + +pointer pm #I Pixel mask to be inverted + +int i, naxes, axlen[IM_MAXDIM], depth, npix, val +pointer sp, v, buf, one +bool pm_linenotempty() + +begin + call pm_gsize (pm, naxes, axlen, depth) + + call smark (sp) + call salloc (v, IM_MAXDIM, TY_LONG) + call salloc (buf, axlen[1], TY_INT) + call salloc (one, 6, TY_INT) + + npix = axlen[1] + RLI_LEN(one) = 2 + RLI_AXLEN(one) = npix + Memi[one+3] = 1 + Memi[one+4] = npix + Memi[one+5] = 1 + + call amovkl (long(1), Meml[v], IM_MAXDIM) + repeat { + if (pm_linenotempty (pm, Meml[v])) { + call pmglpi (pm, Meml[v], Memi[buf], 0, npix, 0) + do i = 0, npix-1 { + val = Memi[buf+i] + if (val == 0) + Memi[buf+i] = 1 + else + Memi[buf+i] = 0 + } + call pmplpi (pm, Meml[v], Memi[buf], 0, npix, PIX_SRC) + } else + call pmplri (pm, Meml[v], Memi[one], 0, npix, PIX_SRC) + + do i = 2, naxes { + Meml[v+i-1] = Meml[v+i-1] + 1 + if (Meml[v+i-1] <= axlen[i]) + break + else if (i < naxes) + Meml[v+i-1] = 1 + } + } until (Meml[v+naxes-1] > axlen[naxes]) + + call sfree (sp) +end + + +# XT_MATCH -- Set the pixel mask to match the reference image. +# This matches sizes and physical coordinates and allows the +# original mask to be smaller or larger than the reference image. +# Subsequent use of the pixel mask can then work in the logical +# coordinates of the reference image. The mask values are the maximum +# of the mask values which overlap each reference image pixel. +# A null input returns a null output. + +procedure xt_match (im, refim, match) + +pointer im #U Pixel mask image pointer +pointer refim #I Reference image pointer +int match #I Match by physical coordinates? + +int i, j, k, l, i1, i2, j1, j2, nc, nl, ncpm, nlpm, nx, val +double x1, x2, y1, y2, lt[6], lt1[6], lt2[6] +long vold[IM_MAXDIM], vnew[IM_MAXDIM] +pointer pm, pmnew, imnew, mw, ctx, cty, bufref, bufpm + +int imstati() +pointer pm_open(), mw_openim(), im_pmmapo(), imgl1i(), mw_sctran() +bool pm_empty(), pm_linenotempty() +errchk pm_open, mw_openim, im_pmmapo + +begin + if (im == NULL) + return + + # Set sizes. + nc = IM_LEN(refim,1) + nl = IM_LEN(refim,2) + ncpm = IM_LEN(im,1) + nlpm = IM_LEN(im,2) + + # If the mask is empty and the sizes are the same then it does not + # matter if the two are actually matched in physical coordinates. + pm = imstati (im, IM_PMDES) + if (pm_empty(pm) && nc == ncpm && nl == nlpm) + return + + # Compute transformation between reference (logical) coordinates + # and mask (physical) coordinates if desired. + + mw = mw_openim (im) + call mw_gltermd (mw, lt, lt[5], 2) + call mw_close (mw) + + if (match == YES) { + mw = mw_openim (refim) + call mw_gltermd (mw, lt2, lt2[5], 2) + call mw_close (mw) + } else + call amovd (lt, lt2, 6) + + # Combine lterms. + call mw_invertd (lt, lt1, 2) + call mw_mmuld (lt1, lt2, lt, 2) + call mw_vmuld (lt, lt[5], lt[5], 2) + lt[5] = lt2[5] - lt[5] + lt[6] = lt2[6] - lt[6] + do i = 1, 6 + lt[i] = nint (1D6 * (lt[i]-int(lt[i]))) / 1D6 + int(lt[i]) + + # Check for a rotation. For now don't allow any rotation. + if (lt[2] != 0. || lt[3] != 0.) + call error (1, "Image and mask have a relative rotation") + + # Check for an exact match. + if (lt[1] == 1D0 && lt[4] == 1D0 && lt[5] == 0D0 && lt[6] == 0D0 && + nc == ncpm && nl == nlpm) + return + + # Set reference to mask coordinates. + mw = mw_openim (im) + call mw_sltermd (mw, lt, lt[5], 2) + ctx = mw_sctran (mw, "logical", "physical", 1) + cty = mw_sctran (mw, "logical", "physical", 2) + + # Create a new pixel mask of the required size and offset. + # Do dummy image I/O to set the header. + pmnew = pm_open (NULL) + call pm_ssize (pmnew, 2, IM_LEN(refim,1), 27) + imnew = im_pmmapo (pmnew, NULL) + bufref = imgl1i (imnew) + + # Compute region of mask overlapping the reference image. + call mw_ctrand (ctx, 1-0.5D0, x1, 1) + call mw_ctrand (ctx, nc+0.5D0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1D-5)) + i2 = min (ncpm, nint(max(x1,x2)-1D-5)) + call mw_ctrand (cty, 1-0.5D0, y1, 1) + call mw_ctrand (cty, nl+0.5D0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1D-5)) + j2 = min (nlpm, nint(max(y1,y2)-1D-5)) + + # Set the new mask values to the maximum of all mask values falling + # within each reference pixel in the overlap region. + if (i1 <= i2 && j1 <= j2) { + nx = i2 - i1 + 1 + vold[1] = i1 + vnew[1] = 1 + + # If the scales are the same then it is just a problem of + # padding. In this case use range lists for speed. + if (lt[1] == 1D0 && lt[4] == 1D0) { + call malloc (bufpm, 3+3*nc, TY_INT) + k = nint (lt[5]) + l = nint (lt[6]) + do j = max(1-l,j1), min(nl-l,j2) { + vold[2] = j + call pmglri (pm, vold, Memi[bufpm], 0, nc, PIX_SRC) + if (k != 0) { + bufref = bufpm + do i = 2, Memi[bufpm] { + bufref = bufref + 3 + Memi[bufref] = Memi[bufref] + k + } + } + vnew[2] = j + l + call pmplri (pmnew, vnew, Memi[bufpm], 0, nc, PIX_SRC) + } + bufref = NULL + + # Do all the geometry and pixel size matching. This can + # be slow. + } else { + call malloc (bufpm, nx, TY_INT) + call malloc (bufref, nc, TY_INT) + do j = 1, nl { + call mw_ctrand (cty, j-0.5D0, y1, 1) + call mw_ctrand (cty, j+0.5D0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1D-5)) + j2 = min (nlpm, nint(max(y1,y2)-1D-5)) + if (j2 < j1) + next + + vnew[2] = j + call aclri (Memi[bufref], nc) + do l = j1, j2 { + vold[2] = l + if (!pm_linenotempty (pm, vold)) + next + call pmglpi (pm, vold, Memi[bufpm], 0, nx, 0) + do i = 1, nc { + call mw_ctrand (ctx, i-0.5D0, x1, 1) + call mw_ctrand (ctx, i+0.5D0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1D-5)) + i2 = min (ncpm, nint(max(x1,x2)-1D-5)) + if (i2 < i1) + next + val = Memi[bufref+i-1] + do k = i1-vold[1], i2-vold[1] + val = max (val, Memi[bufpm+k]) + Memi[bufref+i-1] = val + } + } + call pmplpi (pmnew, vnew, Memi[bufref], 0, nc, PIX_SRC) + } + } + call mfree (bufref, TY_INT) + call mfree (bufpm, TY_INT) + } + + call mw_close (mw) + call xt_pmunmap (im) + im = imnew + call imseti (im, IM_PMDES, pmnew) +end diff --git a/pkg/xtools/fixpix/ytfixpix.x b/pkg/xtools/fixpix/ytfixpix.x new file mode 100644 index 00000000..e93b4c07 --- /dev/null +++ b/pkg/xtools/fixpix/ytfixpix.x @@ -0,0 +1,281 @@ +include <imhdr.h> +include <imset.h> +include <pmset.h> +include "xtfixpix.h" + +# This version uses an internal copy of the input mask rather than modifying +# the input mask. + + +# XT_FPINIT -- Initialize FIXPIX data structure. +# If the mask is null or empty a null pointer is returned. +# If the mask is not empty the mask is examined for bad pixels requiring +# column interpolation. The columns and interpolation endpoints are +# recorded. Note that line interpolation does not need to be mapped since +# this can be done efficiently as the reference image is accessed line by +# line. + +pointer procedure yt_fpinit (pmin, lvalin, cvalin) + +pointer pmin #I Pixel mask +int lvalin #I Input line interpolation code +int cvalin #I Input column interpolation code + +int i, j, k, l, n, nc, nl, l1, l2, lmin, lmax, ncols, lval, cval, ncompress +short val +long v[IM_MAXDIM] +pointer pm, fp, ptr, col, pl1, pl2 +pointer sp, buf, cols + +bool pm_empty() +pointer pm_newcopy() +errchk pmglrs, pmplrs + +begin + # Check for empty mask. + if (pmin == NULL) + return (NULL) + if (pm_empty (pmin)) + return (NULL) + + # Make an internal copy of the mask. + pm = pm_newcopy (pmin) + + # Get mask size. + call pm_gsize (pm, i, v, j) + nc = v[1] + nl = v[2] + + # Allocate memory and data structure. + call smark (sp) + call salloc (buf, 3*max(nc, nl), TY_SHORT) + call salloc (cols, nc, TY_SHORT) + call calloc (fp, FP_LEN, TY_STRUCT) + + # Set the mask codes. Go through the mask and change any mask codes + # that match the input mask code to the output mask code (if they are + # different). This is done to move the mask codes to a range that + # won't conflict with the length values. For any other code replace + # the value by the length of the bad region along the line. This + # value will be used in comparison to the length along the column for + # setting the interpolation for the narrower dimension. + + if ((IS_INDEFI(lvalin)||lvalin<1) && (IS_INDEFI(cvalin)||cvalin<1)) { + lval = FP_LDEF + cval = FP_CDEF + } else if (IS_INDEFI(lvalin) || lvalin < 1) { + lval = FP_LDEF + cval = mod (cvalin - 1, nc) + 1 + if (lval == cval) + lval = FP_CDEF + } else if (IS_INDEFI(cvalin) || cvalin < 1) { + lval = mod (lvalin - 1, nc) + 1 + cval = FP_CDEF + if (cval == lval) + cval = FP_LDEF + } else if (lvalin != cvalin) { + lval = mod (lvalin - 1, nc) + 1 + cval = mod (cvalin - 1, nc) + 1 + } else { + call mfree (fp, TY_STRUCT) + call sfree (sp) + call error (1, "Interpolation codes cannot be the same") + } + call yt_fpsinterp (pmin, pm, nc, nl, v, Mems[buf], lvalin, cvalin, + lval, cval) + + # Go through and check if there is any need for column interpolation; + # i.e. are there any mask values different from the line interpolation. + + call aclrs (Mems[cols], nc) + call amovkl (long(1), v, IM_MAXDIM) + do l = 1, nl { + v[2] = l + call pmglrs (pm, v, Mems[buf], 0, nc, 0) + ptr = buf + 3 + do i = 2, Mems[buf] { + val = Mems[ptr+2] + if (val != lval) { + val = 1 + n = Mems[ptr+1] + call amovks (val, Mems[cols+Mems[ptr]-1], n) + } + ptr = ptr + 3 + } + } + n = 0 + do i = 1, nc + if (Mems[cols+i-1] != 0) + n = n + 1 + + # If there are mask codes for either column interpolation or + # interpolation lengths along lines to compare against column + # interpolation check the interpolation length against the + # column and set the line interpolation endpoints to use. + # compute the minimum and maximum lines that are endpoints + # to restrict the random access pass that will be needed to + # get the endpoint values. + + if (n > 0) { + n = n + 10 + call malloc (col, n, TY_INT) + call malloc (pl1, n, TY_INT) + call malloc (pl2, n, TY_INT) + ncols = 0 + lmin = nl + lmax = 0 + ncompress = 0 + do i = 1, nc { + if (Mems[cols+i-1] == 0) + next + v[1] = i + do l = 1, nl { + v[2] = l + call pmglps (pm, v, Mems[buf+l-1], 0, 1, 0) + } + for (l1=1; l1<=nl && Mems[buf+l1-1]==0; l1=l1+1) + ; + while (l1 <= nl) { + l1 = l1 - 1 + for (l2=l1+1; l2<=nl && Mems[buf+l2-1]!=0; l2=l2+1) + ; + j = 0 + k = nc + l2 - l1 - 1 + do l = l1+1, l2-1 { + val = Mems[buf+l-1] + if (val == cval) + j = j + 1 + else if (val > nc) { + if (val > k) { + j = j + 1 + val = cval + } else + val = lval + v[2] = l + call pmplps (pm, v, val, 0, 1, PIX_SRC) + ncompress = ncompress + 1 + } + } + if (ncompress > 100) { + call pm_compress (pm) + ncompress = 0 + } + if (j > 0) { + if (ncols == n) { + n = n + 10 + call realloc (col, n, TY_INT) + call realloc (pl1, n, TY_INT) + call realloc (pl2, n, TY_INT) + } + j = 1 + l1 - 1 + k = 1 + l2 - 1 + lmin = min (lmin, j, k) + lmax = max (lmax, j, k) + Memi[col+ncols] = i + Memi[pl1+ncols] = j + Memi[pl2+ncols] = k + ncols = ncols + 1 + } + for (l1=l2+1; l1<=nl && Mems[buf+l1-1]==0; l1=l1+1) + ; + } + } + + FP_LMIN(fp) = lmin + FP_LMAX(fp) = lmax + FP_NCOLS(fp) = ncols + FP_PCOL(fp) = col + FP_PL1(fp) = pl1 + FP_PL2(fp) = pl2 + } + + FP_PM(fp) = pm + FP_LVAL(fp) = lval + FP_CVAL(fp) = cval + + call sfree (sp) + return (fp) +end + + +# XT_SINTERP -- Set length of line interpolation regions. +# The mask values are set to the length of any column interpolation +# plus an offset leaving any line and column interpolation codes +# unchanged. These values will be used in a second pass to compare +# to the lengths of line interpolation and then the mask values will +# be reset to one of the line or column interpolation codes based on +# the minimum distance. + +procedure yt_fpsinterp (pmin, pm, nc, nl, v, data, lvalin, cvalin, + lvalout, cvalout) + +pointer pmin #I Input pixel mask +pointer pm #I Modified pixel mask +int nc, nl #I Mask size +long v[ARB] #I Coordinate vector +short data[ARB] #I Data buffer +int lvalin #I Input line interpolation code +int cvalin #I Input column interpolation code +int lvalout #I Output line interpolation code +int cvalout #I Output column interpolation code + +int c, l, c1, c2, val +bool pm_linenotempty() + +begin + call amovkl (long(1), v, IM_MAXDIM) + do l = 1, nl { + v[2] = l + if (!pm_linenotempty (pmin, v)) + next + + call pmglps (pmin, v, data, 0, nc, 0) + + for (c1=1; c1<=nc && data[c1]==0; c1=c1+1) + ; + while (c1 <= nc) { + for (c2=c1+1; c2<=nc && data[c2]!=0; c2=c2+1) + ; + c2 = c2 - 1 + do c = c1, c2 { + val = data[c] + if (val == lvalin) { + if (lvalin != lvalout) + data[c] = lvalout + } else if (val == cvalin) { + if (cvalin != cvalout) + data[c] = cvalout + } else { + data[c] = nc + c2 - c1 + 1 + } + } + for (c1=c2+2; c1<=nc && data[c1]==0; c1=c1+1) + ; + } + + call pmplps (pm, v, data, 0, nc, PIX_SRC) + } +end + + +# XT_FPFREE -- Free FIXPIX data structures. + +procedure yt_fpfree (fp) + +pointer fp #U FIXPIX data structure + +begin + if (fp == NULL) + return + call mfree (FP_PCOL(fp), TY_INT) + call mfree (FP_PL1(fp), TY_INT) + call mfree (FP_PL2(fp), TY_INT) + if (FP_PV1(fp) != NULL) + call mfree (FP_PV1(fp), FP_PIXTYPE(fp)) + if (FP_PV2(fp) != NULL) + call mfree (FP_PV2(fp), FP_PIXTYPE(fp)) + if (FP_DATA(fp) != NULL) + call mfree (FP_DATA(fp), FP_PIXTYPE(fp)) + call pm_close (FP_PM(fp)) + call mfree (fp, TY_STRUCT) +end diff --git a/pkg/xtools/fixpix/ytpmmap.x b/pkg/xtools/fixpix/ytpmmap.x new file mode 100644 index 00000000..e41fb4f8 --- /dev/null +++ b/pkg/xtools/fixpix/ytpmmap.x @@ -0,0 +1,961 @@ +include <mach.h> +include <ctype.h> +include <error.h> +include <imhdr.h> +include <imset.h> +include <pmset.h> +include <mwset.h> +include <syserr.h> +include <math/iminterp.h> + +# Pixel mask matching options. +define PM_MATCH "|logical|physical|world|offset|" +define PM_LOGICAL 1 # Match in logical coordinates +define PM_PHYSICAL 2 # Match in physical coordinates +define PM_WORLD 3 # Match in world coordinates +define PM_OFFSET 4 # Match in physical with WCS offset + + +# XT_PMMAP/XT_MAPPM -- Open a pixel mask READ_ONLY. +# +# This routine maps multiple types of mask files and designations. +# It may match the mask coordinates to the reference image based on the +# physical coordinate system so the mask may be of a different size. +# The mask name is returned so that the task has the name pointed to by "BPM". +# A null filename is allowed and returns NULL. +# +# Modified to use xt_maskname with the reference image extension name. +# Minor bug fixes in xt_match. + +pointer procedure yt_pmmap (pmname, refim, mname, sz_mname) + +char pmname[ARB] #I Pixel mask name +pointer refim #I Reference image pointer +char mname[ARB] #O Expanded mask name +int sz_mname #O Size of expanded mask name + +pointer yt_mappm() +errchk yt_mappm + +begin + return (yt_mappm (pmname, refim, "physical", mname, sz_mname)) +end + +pointer procedure yt_mappm (pmname, refim, match, mname, sz_mname) + +char pmname[ARB] #I Pixel mask name +pointer refim #I Reference image pointer +char match[ARB] #I Match by physical coordinates? +char mname[ARB] #O Expanded mask name +int sz_mname #O Size of expanded mask name + +int i, j, flag, nowhite() +pointer sp, fname, extname, im, ref, yt_pmmap1() +bool streq() +errchk yt_pmmap1 + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (extname, SZ_FNAME, TY_CHAR) + + im = NULL + i = nowhite (pmname, Memc[fname], SZ_FNAME) + + # Process invert flags. These occur more than once. + j = 0; flag = 0 + for (i=0; Memc[fname+i]!=EOS; i=i+1) { + if (Memc[fname+i] == '^') + flag = flag + 1 + else { + Memc[fname+j] = Memc[fname+i] + j = j + 1 + } + } + Memc[fname+j] = EOS + if (mod (flag, 2) == 0) + flag = 0 + else + flag = INVERT_MASK + + + # Resolve keyword references. + if (Memc[fname] == '!') { + iferr (call imgstr (refim, Memc[fname+1], Memc[fname], SZ_FNAME)) + Memc[fname] = EOS + } else if (streq (Memc[fname], "BPM")) { + iferr (call imgstr (refim, "BPM", Memc[fname], SZ_FNAME)) + Memc[fname] = EOS + } + + # Resolve other special names. + if (streq (Memc[fname], "EMPTY")) + ref = refim + else + ref = NULL + + # Create the mask. + if (Memc[fname] != EOS) { + iferr (im = yt_pmmap1 (Memc[fname], ref, refim, flag, match)) { + ifnoerr (call imgstr (refim, "extname", Memc[extname], + SZ_FNAME)) { + call xt_maskname (Memc[fname], Memc[extname], READ_ONLY, + Memc[fname], SZ_FNAME) + im = yt_pmmap1 (Memc[fname], ref, refim, flag, match) + } else + im = yt_pmmap1 (Memc[fname], ref, refim, flag, match) + } + } + call strcpy (Memc[fname], mname, sz_mname) + + call sfree (sp) + return (im) +end + + +# XT_PMUNMAP -- Unmap a mask image. +# Note that the imio pointer may be purely an internal pointer opened +# with im_pmmapo so we need to free the pl pointer explicitly. + +procedure yt_pmunmap (im) + +pointer im #I IMIO pointer for mask + +pointer pm +int imstati() + +begin + pm = imstati (im, IM_PMDES) + call pm_close (pm) + call imseti (im, IM_PMDES, NULL) + call imunmap (im) +end + + +# XT_PMMAP1 -- Open a pixel mask READ_ONLY. The input mask may be +# a pixel list image, a non-pixel list image, or a text file. +# Return error if the pixel mask cannot be opened. For pixel masks +# or image masks possibly match the WCS. + +pointer procedure yt_pmmap1 (pmname, ref, refim, flag, match) + +char pmname[ARB] #I Pixel mask name +pointer ref #I Reference image for pixel mask +pointer refim #I Reference image for image or text +int flag #I Mask flag +char match[ARB] #I Match by physical coordinates? + +int imstati(), errcode() +pointer im, pm +pointer im_pmmap(), yt_pmimmap(), yt_pmtext(), yt_pmsection() +bool streq() +errchk yt_match + +begin + im = NULL + + if (streq (pmname, "STDIN")) + im = yt_pmtext (pmname, refim, flag) + + else if (pmname[1] == '[') + im = yt_pmsection (pmname, refim, flag) + + else { + ifnoerr (im = im_pmmap (pmname, READ_ONLY, ref)) { + call yt_match (im, refim, match) + if (flag == INVERT_MASK) { + pm = imstati (im, IM_PMDES) + call yt_pminvert (pm) + call imseti (im, IM_PMDES, pm) + } + } else { + switch (errcode()) { + case SYS_IKIOPEN, SYS_FOPNNEXFIL, SYS_PLBADSAVEF, SYS_FOPEN: + ifnoerr (im = yt_pmimmap (pmname, refim, flag)) + call yt_match (im, refim, match) + else { + switch (errcode()) { + case SYS_IKIOPEN: + im = yt_pmtext (pmname, refim, flag) + default: + call erract (EA_ERROR) + } + } + default: + call erract (EA_ERROR) + } + } + } + + return (im) +end + + +# XT_PMIMMAP -- Open a pixel mask from a non-pixel list image. +# Return error if the image cannot be opened. + +pointer procedure yt_pmimmap (pmname, refim, flag) + +char pmname[ARB] #I Image name +pointer refim #I Reference image pointer +int flag #I Mask flag + +int i, ndim, npix, rop, val +pointer sp, v1, v2, im_in, im_out, pm, mw, data + +int imstati(), imgnli() +pointer immap(), pm_newmask(), im_pmmapo(), imgl1i(), mw_openim() +errchk immap, mw_openim, im_pmmapo + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + + im_in = immap (pmname, READ_ONLY, 0) + pm = imstati (im_in, IM_PMDES) + if (pm != NULL) + return (im_in) + pm = pm_newmask (im_in, 16) + + ndim = IM_NDIM(im_in) + npix = IM_LEN(im_in,1) + + if (flag == INVERT_MASK) + rop = PIX_NOT(PIX_SRC) + else + rop = PIX_SRC + + while (imgnli (im_in, data, Meml[v1]) != EOF) { + if (flag == INVERT_MASK) { + do i = 0, npix-1 { + val = Memi[data+i] + if (val <= 0) + Memi[data+i] = 1 + else + Memi[data+i] = 0 + } + } else { + do i = 0, npix-1 { + val = Memi[data+i] + if (val < 0) + Memi[data+i] = 0 + } + } + call pmplpi (pm, Meml[v2], Memi[data], 0, npix, rop) + call amovl (Meml[v1], Meml[v2], ndim) + } + + im_out = im_pmmapo (pm, im_in) + data = imgl1i (im_out) # Force I/O to set header + mw = mw_openim (im_in) # Set WCS + call mw_saveim (mw, im_out) + call mw_close (mw) + + #call imunmap (im_in) + call yt_pmunmap (im_in) + call sfree (sp) + return (im_out) +end + + +# XT_PMTEXT -- Create a pixel mask from a text file of rectangles. +# Return error if the file cannot be opened. +# This routine only applies to the first 2D plane. + +pointer procedure yt_pmtext (pmname, refim, flag) + +char pmname[ARB] #I Image name +pointer refim #I Reference image pointer +int flag #I Mask flag + +int fd, nc, nl, c1, c2, l1, l2, nc1, nl1, rop +pointer pm, im, mw, dummy + +int open(), fscan(), nscan() +pointer pm_newmask(), im_pmmapo(), imgl1i(), mw_openim() +errchk open,im_pmmapo + +begin + fd = open (pmname, READ_ONLY, TEXT_FILE) + pm = pm_newmask (refim, 16) + + nc = IM_LEN(refim,1) + nl = IM_LEN(refim,2) + + if (flag == INVERT_MASK) + call pl_box (pm, 1, 1, nc, nl, PIX_SET+PIX_VALUE(1)) + + while (fscan (fd) != EOF) { + call gargi (c1) + call gargi (c2) + call gargi (l1) + call gargi (l2) + if (nscan() != 4) { + if (nscan() == 2) { + l1 = c2 + c2 = c1 + l2 = l1 + } else + next + } + + c1 = max (1, c1) + c2 = min (nc, c2) + l1 = max (1, l1) + l2 = min (nl, l2) + nc1 = c2 - c1 + 1 + nl1 = l2 - l1 + 1 + if (nc1 < 1 || nl1 < 1) + next + + # Select mask value based on shape of rectangle. + if (flag == INVERT_MASK) + rop = PIX_CLR + else if (nc1 <= nl1) + rop = PIX_SET+PIX_VALUE(2) + else + rop = PIX_SET+PIX_VALUE(3) + + # Set mask rectangle. + call pm_box (pm, c1, l1, c2, l2, rop) + } + + call close (fd) + im = im_pmmapo (pm, refim) + dummy = imgl1i (im) # Force I/O to set header + mw = mw_openim (refim) # Set WCS + call mw_saveim (mw, im) + call mw_close (mw) + + return (im) +end + + +# XT_PMSECTION -- Create a pixel mask from an image section. +# This only applies the mask to the first plane of the image. + +pointer procedure yt_pmsection (section, refim, flag) + +char section[ARB] #I Image section +pointer refim #I Reference image pointer +int flag #I Mask flag + +int i, j, ip, temp, a[2], b[2], c[2], rop, ctoi() +pointer pm, im, mw, dummy, pm_newmask(), im_pmmapo(), imgl1i(), mw_openim() +errchk im_pmmapo +define error_ 99 + +begin + # This is currently only for 1D and 2D images. + if (IM_NDIM(refim) > 2) + call error (1, "Image sections only allowed for 1D and 2D images") + + # Decode the section string. + call amovki (1, a, 2) + call amovki (1, b, 2) + call amovki (1, c, 2) + do i = 1, IM_NDIM(refim) + b[i] = IM_LEN(refim,i) + + ip = 1 + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == '[') { + ip = ip + 1 + + do i = 1, IM_NDIM(refim) { + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get a:b:c. Allow notation such as "-*:c" + # (or even "-:c") where the step is obviously negative. + + if (ctoi (section, ip, temp) > 0) { # a + a[i] = temp + if (section[ip] == ':') { + ip = ip + 1 + if (ctoi (section, ip, b[i]) == 0) # a:b + goto error_ + } else + b[i] = a[i] + } else if (section[ip] == '-') { # -* + temp = a[i] + a[i] = b[i] + b[i] = temp + ip = ip + 1 + if (section[ip] == '*') + ip = ip + 1 + } else if (section[ip] == '*') # * + ip = ip + 1 + if (section[ip] == ':') { # ..:step + ip = ip + 1 + if (ctoi (section, ip, c[i]) == 0) + goto error_ + else if (c[i] == 0) + goto error_ + } + if (a[i] > b[i] && c[i] > 0) + c[i] = -c[i] + + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (i < IM_NDIM(refim)) { + if (section[ip] != ',') + goto error_ + } else { + if (section[ip] != ']') + goto error_ + } + ip = ip + 1 + } + } + + # In this case make the values be increasing only. + do i = 1, IM_NDIM(refim) + if (c[i] < 0) { + temp = a[i] + a[i] = b[i] + b[i] = temp + c[i] = -c[i] + } + + # Make the mask. + pm = pm_newmask (refim, 16) + + if (flag == INVERT_MASK) { + rop = PIX_SET+PIX_VALUE(1) + call pm_box (pm, 1, 1, IM_LEN(refim,1), IM_LEN(refim,2), rop) + rop = PIX_CLR + } else + rop = PIX_SET+PIX_VALUE(1) + + if (c[1] == 1 && c[2] == 1) + call pm_box (pm, a[1], a[2], b[1], b[2], rop) + + else if (c[1] == 1) + for (i=a[2]; i<=b[2]; i=i+c[2]) + call pm_box (pm, a[1], i, b[1], i, rop) + + else + for (i=a[2]; i<=b[2]; i=i+c[2]) + for (j=a[1]; j<=b[1]; j=j+c[1]) + call pm_point (pm, j, i, rop) + + im = im_pmmapo (pm, refim) + dummy = imgl1i (im) # Force I/O to set header + mw = mw_openim (refim) # Set WCS + call mw_saveim (mw, im) + call mw_close (mw) + + return (im) + +error_ + call error (1, "Error in image section specification") +end + + +# XT_PMINVERT -- Invert a pixel mask by changing 0 to 1 and non-zero to zero. + +procedure yt_pminvert (pm) + +pointer pm #I Pixel mask to be inverted + +int i, naxes, axlen[IM_MAXDIM], depth, npix, val +pointer sp, v, buf, one +bool pm_linenotempty() + +begin + call pm_gsize (pm, naxes, axlen, depth) + + call smark (sp) + call salloc (v, IM_MAXDIM, TY_LONG) + call salloc (buf, axlen[1], TY_INT) + call salloc (one, 6, TY_INT) + + npix = axlen[1] + RLI_LEN(one) = 2 + RLI_AXLEN(one) = npix + Memi[one+3] = 1 + Memi[one+4] = npix + Memi[one+5] = 1 + + call amovkl (long(1), Meml[v], IM_MAXDIM) + repeat { + if (pm_linenotempty (pm, Meml[v])) { + call pmglpi (pm, Meml[v], Memi[buf], 0, npix, 0) + do i = 0, npix-1 { + val = Memi[buf+i] + if (val == 0) + Memi[buf+i] = 1 + else + Memi[buf+i] = 0 + } + call pmplpi (pm, Meml[v], Memi[buf], 0, npix, PIX_SRC) + } else + call pmplri (pm, Meml[v], Memi[one], 0, npix, PIX_SRC) + + do i = 2, naxes { + Meml[v+i-1] = Meml[v+i-1] + 1 + if (Meml[v+i-1] <= axlen[i]) + break + else if (i < naxes) + Meml[v+i-1] = 1 + } + } until (Meml[v+naxes-1] > axlen[naxes]) + + call sfree (sp) +end + + +# XT_MATCH -- Set the pixel mask to match the reference image. +# This matches sizes and possibly the physical coordinates and allows the +# original mask to be smaller or larger than the reference image. +# Subsequent use of the pixel mask can then work in the logical +# coordinates of the reference image. The mask values are the maximum +# of the mask values which overlap each reference image pixel. +# A null input returns a null output. + +procedure yt_match (im, refim, match) + +pointer im #U Pixel mask image pointer +pointer refim #I Reference image pointer +char match[ARB] #I Match by physical coordinates? + +int i, j, k, l, i1, i2, j1, j2, nc, nl, ncpm, nlpm, nx, val +int pmmatch, maxmaskval +double x1, x2, y1, y2, lt[6], lt1[6], lt2[6] +long vold[IM_MAXDIM], vnew[IM_MAXDIM] +pointer str, pm, pmnew, imnew, mw, ctx, cty, bufref, bufpm + +int imstati(), strdic(), envfind(), nscan() +pointer pm_open(), mw_openim(), im_pmmapo(), imgl1i(), mw_sctran() +bool pm_empty(), pm_linenotempty() +errchk yt_match_world, pm_open, mw_openim, im_pmmapo + +begin + if (im == NULL) + return + + # Set sizes. + nc = IM_LEN(refim,1) + nl = IM_LEN(refim,2) + ncpm = IM_LEN(im,1) + nlpm = IM_LEN(im,2) + + # If the mask is empty and the sizes are the same then it does not + # matter if the two are actually matched in physical coordinates. + pm = imstati (im, IM_PMDES) + if (pm_empty(pm) && nc == ncpm && nl == nlpm) + return + + # Set match type. + call malloc (str, SZ_FNAME, TY_CHAR) + call sscan (match) + call gargwrd (Memc[str], SZ_FNAME); call gargi (maxmaskval) + if (nscan() == 1) + maxmaskval = 1 + pmmatch = strdic (Memc[str], Memc[str], SZ_FNAME, PM_MATCH) + if (pmmatch == 0 && match[1] != EOS) { + if (envfind (match, Memc[str], SZ_FNAME) > 0) { + call sscan (Memc[str]) + call gargwrd (Memc[str], SZ_FNAME); call gargi (maxmaskval) + if (nscan() == 1) + maxmaskval = 1 + pmmatch = strdic (Memc[str], Memc[str], SZ_FNAME, PM_MATCH) + } else + pmmatch = PM_LOGICAL + } else { + if (envfind ("pmmatch", Memc[str], SZ_FNAME) > 0) { + call sscan (Memc[str]) + call gargwrd (Memc[str], SZ_FNAME); call gargi (maxmaskval) + if (nscan() == 1) + maxmaskval = 1 + pmmatch = strdic (Memc[str], Memc[str], SZ_FNAME, PM_MATCH) + } + } + call mfree (str, TY_CHAR) + if (pmmatch == 0) + call error (1, "Unknown or invalid pixel mask matching option") + + if (pmmatch == PM_WORLD) { + call yt_match_world (im, refim, maxmaskval) + return + } + + # Compute transformation between reference (logical) coordinates + # and mask (physical) coordinates. Apply a world coordinate + # offset if desired. + + mw = mw_openim (im) + if (pmmatch == PM_OFFSET) { + call mw_gwtermd (mw, lt[5], lt1, lt, 2) + ctx = mw_sctran (mw, "world", "physical", 0) + call mw_ctrand (ctx, lt1, lt1[5], 2) + } else + call aclrd (lt1[5], 2) + call mw_gltermd (mw, lt, lt[5], 2) + call mw_close (mw) + + if (pmmatch == PM_LOGICAL) + call amovd (lt, lt2, 6) + else { + mw = mw_openim (refim) + if (pmmatch == PM_OFFSET) { + ctx = mw_sctran (mw, "world", "physical", 0) + call mw_ctrand (ctx, lt1, lt1[3], 2) + lt1[5] = nint (lt1[5] - lt1[3]) + lt1[6] = nint (lt1[6] - lt1[4]) + } + call mw_gltermd (mw, lt2, lt2[5], 2) + lt2[5] = lt2[5] - lt1[5] + lt2[6] = lt2[6] - lt1[6] + call mw_close (mw) + } + + # Combine lterms. + call mw_invertd (lt, lt1, 2) + call mw_mmuld (lt1, lt2, lt, 2) + call mw_vmuld (lt, lt[5], lt[5], 2) + lt[5] = lt2[5] - lt[5] + lt[6] = lt2[6] - lt[6] + do i = 1, 6 + lt[i] = nint (1D6 * (lt[i]-int(lt[i]))) / 1D6 + int(lt[i]) + + # Check for a rotation. For now don't allow any rotation. + if (lt[2] != 0. || lt[3] != 0.) + call error (1, "Image and mask have a relative rotation") + + # Check for an exact match. + if (lt[1] == 1D0 && lt[4] == 1D0 && lt[5] == 0D0 && lt[6] == 0D0 && + nc == ncpm && nl == nlpm) + return + + # Set reference to mask coordinates. + mw = mw_openim (im) + call mw_sltermd (mw, lt, lt[5], 2) + ctx = mw_sctran (mw, "logical", "physical", 1) + cty = mw_sctran (mw, "logical", "physical", 2) + + # Create a new pixel mask of the required size and offset. + # Do dummy image I/O to set the header. + pmnew = pm_open (NULL) + call pm_ssize (pmnew, 2, IM_LEN(refim,1), 27) + imnew = im_pmmapo (pmnew, NULL) + bufref = imgl1i (imnew) + + # Compute region of mask overlapping the reference image. + call mw_ctrand (ctx, 1-0.5D0, x1, 1) + call mw_ctrand (ctx, nc+0.5D0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1D-5)) + i2 = min (ncpm, nint(max(x1,x2)-1D-5)) + call mw_ctrand (cty, 1-0.5D0, y1, 1) + call mw_ctrand (cty, nl+0.5D0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1D-5)) + j2 = min (nlpm, nint(max(y1,y2)-1D-5)) + + # Set the new mask values to the maximum of all mask values falling + # within each reference pixel in the overlap region. + if (i1 <= i2 && j1 <= j2) { + nx = i2 - i1 + 1 + vold[1] = i1 + vnew[1] = 1 + + # If the scales are the same then it is just a problem of + # padding. In this case use range lists for speed. + if (lt[1] == 1D0 && lt[4] == 1D0) { + call malloc (bufpm, 3+3*nc, TY_INT) + k = nint (lt[5]) + l = nint (lt[6]) + do j = max(1-l,j1), min(nl-l,j2) { + vold[2] = j + call plglri (pm, vold, Memi[bufpm], 0, nc, PIX_SRC) + if (k != 0) { + bufref = bufpm + do i = 2, Memi[bufpm] { + bufref = bufref + 3 + Memi[bufref] = Memi[bufref] + k + } + } + vnew[2] = j + l + call pmplri (pmnew, vnew, Memi[bufpm], 0, nc, PIX_SRC) + } + bufref = NULL + + # Do all the geometry and pixel size matching. This can + # be slow. + } else { + call malloc (bufpm, nx, TY_INT) + call malloc (bufref, nc, TY_INT) + do j = 1, nl { + call mw_ctrand (cty, j-0.5D0, y1, 1) + call mw_ctrand (cty, j+0.5D0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1D-5)) + j2 = min (nlpm, nint(max(y1,y2)-1D-5)) + if (j2 < j1) + next + + vnew[2] = j + call aclri (Memi[bufref], nc) + do l = j1, j2 { + vold[2] = l + if (!pm_linenotempty (pm, vold)) + next + call pmglpi (pm, vold, Memi[bufpm], 0, nx, 0) + do i = 1, nc { + call mw_ctrand (ctx, i-0.5D0, x1, 1) + call mw_ctrand (ctx, i+0.5D0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1D-5)) + i2 = min (ncpm, nint(max(x1,x2)-1D-5)) + if (i2 < i1) + next + val = Memi[bufref+i-1] + do k = i1-vold[1], i2-vold[1] + val = max (val, Memi[bufpm+k]) + Memi[bufref+i-1] = val + } + } + call pmplpi (pmnew, vnew, Memi[bufref], 0, nc, PIX_SRC) + } + } + call mfree (bufref, TY_INT) + call mfree (bufpm, TY_INT) + } + + call mw_close (mw) + call yt_pmunmap (im) + im = imnew + call imseti (im, IM_PMDES, pmnew) +end + + +# XT_MATCH_WORLD -- Set the pixel mask to match the reference image in +# world coordinates. The algorithm can fail in various ways, especially +# when higher order WCS are used. This ideally works with images and masks +# that are not greatly skewed in RA/DEC space. + +procedure yt_match_world (im, refim, maxmaskval) + +pointer im #U Pixel mask image pointer +pointer refim #I Reference image pointer +int maxmaskval #I Maximum mask value + +int i, j, k, l, nc, nl, ncpm, nlpm, cstep, lstep, buf, nxmsi, nymsi +int c_im, l_im, c_ref, l_ref, c1_ref, c2_ref, l1_ref, l2_ref +int xmin, xmax, ymin, ymax +double pix_im[2], pix_ref[2], pix_tmp[2], w1[2], w2[2] +real x, y, icstep, ilstep, d[2], der[2,2] +long v[2] +pointer sp, bits, rl +pointer ba, mw_im, mw_ref, ct1, ct2, pm, xmsi, ymsi, xvec, yvec, ptr + +int imstati() +real msieval() +pointer xt_baopen(), pm_open(), im_pmmapo(), imgl1i() +pointer mw_openim(), mw_sctran() +bool pm_empty() +errchk xt_baopen, pm_open, mw_openim, im_pmmapo, msiinit, msifit + +begin + if (im == NULL) + return + + # Set sizes. + ncpm = IM_LEN(im,1) + nlpm = IM_LEN(im,2) + nc = IM_LEN(refim,1) + nl = IM_LEN(refim,2) + + # If the mask is empty and the sizes are the same then it does not + # matter if the two are actually matched in world coordinates. + pm = imstati (im, IM_PMDES) + if (pm_empty(pm) && nc == ncpm && nl == nlpm) + return + + # Allocate working lines. + call smark (sp) + call salloc (bits, nc, TY_INT) + call salloc (rl, 3+3*ncpm, TY_INT) + + # Use a bit array to hold the output in memory compactly. + ba = xt_baopen (nc, nl, maxmaskval) + + # Set logical to logical transformation through the world coordinate + # systems. Use a surface fit to speed up the WCS calculations. + + mw_im = mw_openim (im) + mw_ref = mw_openim (refim) + + # First bound the reference image in world coordinates. + # The image is sampled and a small amount of buffer is used. + + ct1 = mw_sctran (mw_ref, "logical", "world", 3) + cstep = 20; lstep = 20 + icstep = (nc - 1.) / (cstep - 1.); ilstep = (nl - 1.) / (lstep - 1.) + w1[1] = MAX_DOUBLE; w1[2] = -MAX_DOUBLE + w2[1] = MAX_DOUBLE; w2[2] = -MAX_DOUBLE + for (pix_im[2]=1-ilstep; pix_im[2]<=nl+1+ilstep; + pix_im[2]=pix_im[2]+ilstep) { + for (pix_im[1]=1-icstep; pix_im[1]<=nc+1+icstep; + pix_im[1]=pix_im[1]+icstep) { + call mw_ctrand (ct1, pix_im, pix_ref, 2) + w1[1] = min (w1[1], pix_ref[1]) + w1[2] = max (w1[2], pix_ref[1]) + w2[1] = min (w2[1], pix_ref[2]) + w2[2] = max (w2[2], pix_ref[2]) + } + } + call mw_ctfree (ct1) + + # Fit coordinate surfaces for the mapping from the mask to the + # the reference image. This is done because the WCS evaluations + # can be slow. This is done on a subsample and then linear + # interpolation will be done. Provide a buffer to avoid edge + # effects from the subsampling. Bound the mask to what overlaps + # the reference image. + + cstep = 10; lstep = 10; buf = 1 + + ct1 = mw_sctran (mw_im, "logical", "world", 3) + ct2 = mw_sctran (mw_ref, "world", "logical", 3) + + call msiinit (xmsi, II_BILINEAR) + call msiinit (ymsi, II_BILINEAR) + nxmsi = nint ((ncpm - 1.) / cstep + 2*buf + 1) + nymsi = nint ((nlpm - 1.) / lstep + 2*buf + 1) + icstep = (nxmsi - (2.*buf + 1)) / (ncpm - 1.) + ilstep = (nymsi - (2.*buf + 1)) / (nlpm - 1.) + call malloc (xvec, nxmsi*nymsi, TY_REAL) + call malloc (yvec, nxmsi*nymsi, TY_REAL) + xmin=ncpm+1; xmax=0; ymin=nlpm+1; ymax=0 + k = -1 + do j = 1, nymsi { + pix_im[2] = (j - (2*buf)) / ilstep + 1 + do i = 1, nxmsi { + k = k + 1 + pix_im[1] = (i - (2*buf)) / icstep + 1 + call mw_ctrand (ct1, pix_im, pix_tmp, 2) + if (pix_tmp[1] < w1[1] || pix_tmp[1] > w1[2] || + pix_tmp[2] < w2[1] || pix_tmp[2] > w2[2]) { + Memr[xvec+k] = 0 + Memr[yvec+k] = 0 + next + } + + call mw_ctrand (ct2, pix_tmp, pix_ref, 2) + x = pix_ref[1] + y = pix_ref[2] + if (x > 0.5 && x < nc+0.5 && y > 0.5 && y < nl+0.5) { + l = max (1, min (ncpm, nint (pix_im[1]))) + xmin = min (xmin, l) + xmax = max (xmax, l) + l = max (1, min (nlpm, nint (pix_im[2]))) + ymin = min (ymin, l) + ymax = max (ymax, l) + } + + Memr[xvec+k] = x + Memr[yvec+k] = y + } + } + call msifit (xmsi, Memr[xvec], nxmsi, nymsi, nxmsi) + call msifit (ymsi, Memr[yvec], nxmsi, nymsi, nxmsi) + call mfree (xvec, TY_REAL) + call mfree (yvec, TY_REAL) + call mw_close (mw_im) + call mw_close (mw_ref) + + # Expand the mask bound to avoid missing the edge. + i = (xmin - 1) * icstep + (2*buf) - 1 + xmin = (i - (2*buf)) / icstep + 1 + xmin = max (1, min (ncpm, nint(xmin))) + i = (xmax - 1) * icstep + (2*buf) + 1.99 + xmax = (i - (2*buf)) / icstep + 1 + xmax = max (1, min (ncpm, nint(xmax))) + j = (ymin - 1) * ilstep + (2*buf) - 1 + ymin = (j - (2*buf)) / ilstep + 1 + ymin = max (1, min (nlpm, nint(ymin))) + j = (ymax - 1) * ilstep + (2*buf) + 1.99 + ymax = (j - (2*buf)) / ilstep + 1 + ymax = max (1, min (nlpm, nint(ymax))) + + # Determine size of mask pixel in reference system. + # This is approximate because we don't take into account the + # shape of the transformed square mask pixels. + + x = (xmax+xmin)/2; y = (ymax+ymin)/2 + x = (x - 1) * icstep + (2*buf); y = (y - 1) * ilstep + (2*buf) + call msider (xmsi, x, y, der, 2, 2, 2) + d[1] = max (abs(der[2,1]), abs(der[1,2])) * icstep + call msider (ymsi, x, y, der, 2, 2, 2) + d[2] = max (abs(der[2,1]), abs(der[1,2])) * ilstep + + # Go through each mask pixel and add to the new mask. + # This uses range lists to quickly skip good pixels. + + v[1] = 1 + do l_im = ymin, ymax { + v[2] = l_im + call plglri (pm, v, Memi[rl], 0, ncpm, PIX_SRC) + y = (l_im - 1) * ilstep + (2*buf) + ptr = rl + do k = RL_FIRST, RLI_LEN(rl) { + ptr = ptr + RL_LENELEM + c_im = Memi[ptr+RL_XOFF] + if (c_im > xmax) + next + if (c_im+Memi[ptr+RL_NOFF]-1 < xmin) + next + x = (c_im - 1) * icstep + (2*buf) - icstep + do c_im = 1, Memi[ptr+RL_NOFF] { + x = x + icstep + pix_ref[1] = msieval (xmsi, x, y) + pix_ref[2] = msieval (ymsi, x, y) + pix_tmp[1] = max (1D0, pix_ref[1] - 0.45 * d[1]) + pix_tmp[2] = min (double(nc), pix_ref[1] + 0.45 * d[1]) + if (pix_tmp[2] < 1 || pix_tmp[1] > nc) + next + c1_ref = nint (pix_tmp[1]) + c2_ref = nint (pix_tmp[2]) + pix_tmp[1] = max (1D0, pix_ref[2] - 0.45 * d[2]) + pix_tmp[2] = min (double(nl), pix_ref[2] + 0.45 * d[2]) + if (pix_tmp[2] < 1 || pix_tmp[1] > nl) + next + l1_ref = nint (pix_tmp[1]) + l2_ref = nint (pix_tmp[2]) + do l_ref = l1_ref, l2_ref { + do c_ref = c1_ref, c2_ref { + call xt_bapi (ba, c_ref, l_ref, + Memi[ptr+RL_VOFF], 1) + } + } + } + } + } + + call msifree (xmsi) + call msifree (ymsi) + call yt_pmunmap (im) + + # Create a new pixel mask of the required size and populate. + # Do dummy image I/O to set the header. + + pm = pm_open (NULL) + call pm_ssize (pm, 2, IM_LEN(refim,1), 27) + im = im_pmmapo (pm, NULL) + ptr = imgl1i (im) + + do j = 1, nl { + call xt_bagi (ba, 1, j, Memi[bits], nc) + v[2] = j + call pmplpi (pm, v, Memi[bits], 0, nc, PIX_SRC) + } + + call imseti (im, IM_PMDES, pm) + + call xt_baclose (ba) + call sfree (sp) +end diff --git a/pkg/xtools/getdatatype.x b/pkg/xtools/getdatatype.x new file mode 100644 index 00000000..9502e82f --- /dev/null +++ b/pkg/xtools/getdatatype.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define NTYPES 9 + +# GETDATATYPE -- Convert a character to an IRAF data type + +int procedure getdatatype (ch) + +char ch +int i, type_code[NTYPES] +int stridx() + +string types "bcusilrdx" # Supported data types +data type_code /TY_UBYTE, TY_CHAR, TY_USHORT, TY_SHORT, TY_INT, TY_LONG, + TY_REAL, TY_DOUBLE, TY_COMPLEX/ + +begin + i = stridx (ch, types) + if (i == 0) + return (ERR) + else + return (type_code[stridx(ch,types)]) +end + + +# DTSTRING -- Convert a datatype to a string + +procedure dtstring (datatype, str, maxchar) + +int datatype # IRAF datatype +char str[maxchar] # Output string +int maxchar # Maximum characters in string + +begin + switch (datatype) { + case TY_UBYTE: + call strcpy ("unsigned byte", str, maxchar) + case TY_CHAR: + call strcpy ("character", str, maxchar) + case TY_USHORT: + call strcpy ("unsigned short", str, maxchar) + case TY_SHORT: + call strcpy ("short", str, maxchar) + case TY_INT: + call strcpy ("integer", str, maxchar) + case TY_LONG: + call strcpy ("long", str, maxchar) + case TY_REAL: + call strcpy ("real", str, maxchar) + case TY_DOUBLE: + call strcpy ("double", str, maxchar) + case TY_COMPLEX: + call strcpy ("complex", str, maxchar) + default: + call strcpy ("unknown", str, maxchar) + } +end diff --git a/pkg/xtools/gstrdetab.x b/pkg/xtools/gstrdetab.x new file mode 100644 index 00000000..b51ac019 --- /dev/null +++ b/pkg/xtools/gstrdetab.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GSTRDETAB -- Procedure to remove tabs from a line of text. + +int procedure gstrdetab (line, outline, maxch, tabs) + +char line[ARB], outline[ARB] +int maxch, tabs[ARB] + +int ip, op + +begin + ip = 1 + op = 1 + + while (line[ip] != EOS && op <= maxch) { + if (line[ip] == '\t') { + repeat { + outline[op] = ' ' + op = op + 1 + } until (tabs[op] == YES || op > maxch) + ip = ip + 1 + } else { + outline[op] = line [ip] + ip = ip + 1 + op = op + 1 + } + } + + outline[op] = EOS + return (op-1) +end diff --git a/pkg/xtools/gstrentab.x b/pkg/xtools/gstrentab.x new file mode 100644 index 00000000..2034c7fd --- /dev/null +++ b/pkg/xtools/gstrentab.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GSTRENTAB -- Procedure to replace blanks with tabs and blanks. + +int procedure gstrentab (line, outline, maxch, tabs) + +int maxch, tabs[ARB] +char line[ARB], outline[ARB] + +int ip, op, ltab + +begin + op = 1 + ip = 1 + + repeat { + ltab = ip + while (line[ltab] == ' ' && op <= maxch) { + ltab = ltab + 1 + if (tabs[ltab] == YES) { + outline[op] = '\t' + ip = ltab + op = op + 1 + } + } + for (; ip < ltab && op <= maxch; ip = ip + 1) { + outline[op] = ' ' + op = op + 1 + } + if (line[ip] == EOS || op >= maxch +1) + break + outline[op] = line[ip] + op = op + 1 + ip = ip + 1 + } until (line[ip] == EOS || op >= maxch+1) + + outline[op] = EOS + return (op-1) +end + diff --git a/pkg/xtools/gstrsettab.x b/pkg/xtools/gstrsettab.x new file mode 100644 index 00000000..ef7d5f68 --- /dev/null +++ b/pkg/xtools/gstrsettab.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GSTRSETTAB -- Procedure to set tabs, using the integer array tabs. +# The first tabstop is set at first_tabstop, with subsequent tabstops +# at tabsize intervals. + +procedure gstrsettab (tabs, maxtabs, first_tabstop, tabsize) + +int tabs[ARB], first_tabstop, tabsize +int i, maxtabs + +begin + for (i=1; i <= maxtabs; i = i + 1) { + if (i < first_tabstop) + tabs[i] = NO + else if (i == first_tabstop) + tabs[i] = YES + else if (mod ((i - first_tabstop), tabsize) == 0) + tabs[i] = YES + else + tabs[i] = NO + } +end diff --git a/pkg/xtools/gtools/Revisions b/pkg/xtools/gtools/Revisions new file mode 100644 index 00000000..cca0335c --- /dev/null +++ b/pkg/xtools/gtools/Revisions @@ -0,0 +1,172 @@ +.help revisions Jun88 pkg.xtools.gtools +.nf +===== +V2.12 +===== + +pkg$xtools/gtools/gtlabax.x + Added workaround to avoid GUI message. (2/1/99, Valdes) + +======= +V2.11.2 +======= + +pkg$xtools/gtools/gtcolon.x + Corrected definition of btoi. (8/11/99, Valdes) + +pkg$xtools/gtools/gtreset.x + This routine was declared as a function rather than a subroutine + as it should be. (7/21/99, Valdes) + +pkg$xtools/gtools/gtlabax.x + Gmsg call is only made if there is a GUI. (7/14/99, Valdes) + +* +pkg$xtools/gtools/gthelp.x - +pkg$xtools/gtools/gtpage.x - + New version with access to most of the GIO parameters and with + GUI messages. (5/11/99, Valdes) + +======= +V2.11.1 +======= + +===== +V2.11 +===== +lib$pkg/gtools.h +pkg$xtools/gtools/gtools.h +pkg$xtools/gtools/gtcolon.x +pkg$xtools/gtools/gtset.x +pkg$xtools/gtools/gtget.x +pkg$xtools/gtools/gtlabax.x +pkg$xtools/gtools/gtinit.x +pkg$xtools/gtools/gtools.hlp + Added GTDRAWTITLE, GTDRAWXLABELS, and GTDRAWYLABELS to control the + three label components as blocks and independent of the user or + application settings of the title parameters and label parameters. + The help and key files were updated. + (4/26/96, Valdes) + +========= +V2.10.4p2 +========= + +pkg$xtools/gtools/gtascale.x + The case with gt==NULL was not correct. (8/16/95, Valdes) + +lib$pkg/gtools.h +pkg$xtools/gtools/gtools.h +pkg$xtools/gtools/gtget.x +pkg$xtools/gtools/gtset.x +pkg$xtools/gtools/gtwindow.x +pkg$xtools/gtools/gtcopy.x +pkg$xtools/gtools/gtinit.x +pkg$xtools/gtools/gtswind.x +pkg$xtools/gtools/gtcolon.x +pkg$xtools/gtools/gtascale.x + Two new parameters, GTXFLIP and GTYFLIP, were added. These boolean + parameters can be set to flip vectors plotted with the gtools + functions. In the gt_window functions flips are now done using + these new parameters rather than explicitly setting the plot + limits. Previously this meant that any use of the flip would + not allow autoscaling; that is a new graph with different limits + would only cover the fixed limits. It also mean that the 'a' + window function would reset the flip. (12/8/93, Valdes) + +pkg$xtools/gtools/gtplot.x + The gio color marks are drawn using the G_PLCOLOR rather than G_PMCOLOR + so the code was change to work appropriately. (11/11/93, Valdes) + +=========== +V2.10.3Beta +=========== + +pgk$xtools/gtools/gtools.hlp +pgk$xtools/gtools/gtinit.x +pgk$xtools/gtools/gtcolon.x +pgk$xtools/gtools/Revisions +pgk$xtools/gtools/gtvplot.x +pgk$xtools/gtools/gtset.x +pgk$xtools/gtools/gtplot.x +pgk$xtools/gtools/gtget.x +pgk$xtools/gtools/gtcopy.x +pgk$xtools/gtools/gtools.h + Added color option. (10/29/92, Valdes) + +pkg$xtools/gtools/gtcolon.x + The :/parameters case was resetting the subtitle string. + (12/28/90, Valdes, diagnosed by Jeff Munn) + +pkg$xtools/gtools/gtget.x + When the sysid option was added the gtgets routine was not modified + to return the setting. This has been added. (7/12/90, Valdes) + +pkg$xtools/gtools/gtget.x + When the histogram type was added the gtgets routine was not modified + to return this type. This has been added. (6/28/90, Valdes) + +==== +V2.9 +==== + +pkg$xtools/gtools + 1. Added new colon command :/sysid to turn off system ID banner. + 2. Added new colon command :/type hist to plot histogram type lines. + (10/5/89, Valdes) + +pkg$xtools/gtools/gtascale.x + Made a trivial change, a temp variable is now used for switching two + variables, to work around an optimizer bug on Sun3/OS4/f68881. + (9/21/89, Valdes) + +==== +V2.8 +==== + +pkg$xtools/gtools/gtascale.x + + Added a procedure to complement GSCALE to scale data only within + a GTOOLS window. (11/30/87 Valdes) + +pkg$xtools/gtools/gtvplot.x + + Added a vector version of GT_PLOT. (11/5/87 Valdes) + +==== +V2.5 +==== + +pkg$xtools/gtools/*.x + Valdes, February 17, 1987 + 1. Requires GIO changes. + 2. Eliminated GT_PAGE, GT_HELP, GT_WAITPAGE. + 3. Argument change to GT_COLON. + +pkg$xtools/gtools/gtset.x + Valdes, January 30, 1987 + 1. In gtsets if the specified value string is not recognized an + error message is printed to STDERR. + +pkg$xtools/gtools/gthelp.x +pkg$xtools/gtools/gtwindow.x +pkg$xtools/gtools/gtcolon.x + Valdes, January 13, 1987 + 1. GT_HELP now calls the system PAGEFILE procedure. This procedure + should now be obsolete. + 2. Modified GT_WINDOW and GT_COLON to call PAGEFILE instead of GT_HELP. + +gtools$gtwindow.x: Valdes, June 11, 1986 + 1. Added new procedure gt_window. It is a cursor driven procedure + for windowing graphs using the gtools pointer. The help + page for gtools was also modified to show the windowing options. + +gtools$gtcur.x: Valdes, May 10, 1986 + 1. Took out "Confirm:" prompt so that cursor input from a file does + not cause anything to be printed. Two EOF's (carriage return or + actual EOF) or a 'q' are required to exit thus protecting the user + from an inadvertent carriage return. + +From Valdes Oct 29, 1985: + +Added call to gmftitle in gtlabax. This insures that graphics written to +a metacode file can use the metacode tools locate graphics. +.endhelp diff --git a/pkg/xtools/gtools/gtascale.x b/pkg/xtools/gtools/gtascale.x new file mode 100644 index 00000000..06f5c0ef --- /dev/null +++ b/pkg/xtools/gtools/gtascale.x @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include "gtools.h" + +# GT_ASCALE -- Set graphics window to the range of the data. +# Unlike GASCALE the data is limited to the GTOOLS window. +# It also clips a fraction of the high and low points. + +procedure gt_ascale (gp, gt, x, y, npts) + +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +real x[npts], y[npts] # Data to scale +int npts # Number of data points + +int i, j, k, n +real xmin, xmax, ymin, ymax, x1, x2, y1, y2, temp +pointer buf + +begin + if (gt == NULL) { + call gascale (gp, x, npts, 1) + call gascale (gp, y, npts, 1) + return + } + + if (GT_TRANSPOSE(gt) == NO) { + xmin = GT_XMIN(gt) + xmax = GT_XMAX(gt) + ymin = GT_YMIN(gt) + ymax = GT_YMAX(gt) + } else { + ymin = GT_XMIN(gt) + ymax = GT_XMAX(gt) + xmin = GT_YMIN(gt) + xmax = GT_YMAX(gt) + } + + if (IS_INDEF(xmin)) + xmin = -MAX_REAL + if (IS_INDEF(xmax)) + xmax = MAX_REAL + if (IS_INDEF(ymin)) + ymin = -MAX_REAL + if (IS_INDEF(ymax)) + ymax = MAX_REAL + + temp = max (xmin, xmax) + xmin = min (xmin, xmax) + xmax = temp + temp = max (ymin, ymax) + ymin = min (ymin, ymax) + ymax = temp + + x1 = xmax + x2 = xmin + y1 = ymax + y2 = ymin + n = 0 + do i = 1, npts { + if ((x[i]<xmin)||(x[i]>xmax)||(y[i]<ymin)||(y[i]>ymax)) + next + x1 = min (x1, x[i]) + x2 = max (x2, x[i]) + y1 = min (y1, y[i]) + y2 = max (y2, y[i]) + n = n + 1 + } + if ((GT_LCLIP(gt) > 0. || GT_HCLIP(gt) > 0.) && n > 0) { + call malloc (buf, n, TY_REAL) + n = 0 + do i = 1, npts { + if ((x[i]<xmin)||(x[i]>xmax)||(y[i]<ymin)||(y[i]>ymax)) + next + Memr[buf+n] = y[i] + n = n + 1 + } + call asrtr (Memr[buf], Memr[buf], n) + if (GT_LCLIP(gt) > 1.) + j = GT_LCLIP(gt) / 100. * n + else + j = max (0., GT_LCLIP(gt) * n) + if (GT_HCLIP(gt) > 1.) + k = GT_HCLIP(gt) / 100. * n + else + k = max (0., GT_HCLIP(gt) * n) + k = n - 1 - k + if (j > k) { + y1 = Memr[buf+j] + y2 = Memr[buf+k] + } + call mfree (buf, TY_REAL) + } + + if (x1 <= x2) + call gswind (gp, x1, x2, INDEF, INDEF) + if (y1 <= y2) + call gswind (gp, INDEF, INDEF, y1, y2) +end diff --git a/pkg/xtools/gtools/gtcolon.x b/pkg/xtools/gtools/gtcolon.x new file mode 100644 index 00000000..b2a918fb --- /dev/null +++ b/pkg/xtools/gtools/gtcolon.x @@ -0,0 +1,754 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <gset.h> +include "gtools.h" + +define KEY "lib$scr/gtools.key" +define PROMPT "graph format options" + +# Defined colon commands for the GTOOLS package +define CMDS "|help|xview|yview|xwindow|ywindow|sysid|parameters|title|subtitle\ + |comments|xlabel|ylabel|xunits|yunits|drawtitle|drawxlabels|drawylabels\ + |type|mark|line|xsize|ysize|color|xtransform|ytransform|xflip|yflip\ + |transpose|xformat|yformat|xbuf|ybuf|clip|redraw|expand|shift|expand\ + |uivalues|" + +define HELP 1 # Get help +define XVIEW 2 # Set X viewport +define YVIEW 3 # Set Y viewport +define XWINDOW 4 # Set X window +define YWINDOW 5 # Set Y window +define SYSID 6 # Draw SYSID? +define PARAMETERS 7 # Set parameters string +define TITLE 8 # Set title +define SUBTITLE 9 # Set subtitle string +define COMMENTS 10 # Set comment string +define XLABEL 11 # Set X label +define YLABEL 12 # Set Y label +define XUNITS 13 # Set X unit label +define YUNITS 14 # Set Y unit label +define DRAWTITLE 15 # Draw title block? +define DRAWXLABELS 16 # Draw X label block? +define DRAWYLABELS 17 # Draw Y label block? +define TYPE 18 # Set graph type +define MARK 19 # Set symbol mark type +define LINE 20 # Set line type +define XSIZE 21 # Set X symbol size +define YSIZE 22 # Set Y symbol size +define COLOR 23 # Set color +define XTRANSFORM 24 # Set X transformation function +define YTRANSFORM 25 # Set Y transformation function +define XFLIP 26 # X flip +define YFLIP 27 # Y flip +define TRANSPOSE 28 # Transpose graph +define XFORMAT 29 # X format +define YFORMAT 30 # Y format +define XBUF 31 # X buffer distance +define YBUF 32 # X buffer distance +define CLIP 33 # Clipping factors +define REDRAW 34 # Redraw graph +define EXPAND 35 # Expand world coordinates +define SHIFT 36 # Shift world coordinates +define WINDOW 37 # Window command +define UIVALUES 38 # Send UI values + + +# GT_COLON -- Process standard gtools colon commands. + +procedure gt_colon (cmdstr, gp, gt, newgraph) + +char cmdstr[ARB] # Command string +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +int newgraph # Update graph? + +char cmd[SZ_LINE] +int ip, ncmd, ival +real x, y, rval[4] +bool bval + +int nscan(), strdic(), gt_geti(), btoi() +real gt_getr() + +begin + # All GTOOLS commands start with '/'. + if (cmdstr[1] != '/') + return + + # Parse the command string matched against a dictionary. + call sscan (cmdstr[2]) + call gargwrd (cmd, SZ_LINE) + ncmd = strdic (cmd, cmd, SZ_LINE, CMDS) + + # Switch on the command and parse the arguments. + switch (ncmd) { + case HELP: # help: Print help + call gpagefile (gp, KEY, PROMPT) + + case XVIEW: # xview: List or set x viewport. + call gargr (rval[1]) + call gargr (rval[2]) + if (nscan() == 3) { + call gt_setr (gt, GTVXMIN, rval[1]) + call gt_setr (gt, GTVXMAX, rval[2]) + } else { + call printf ("xview = %g %g\n") + call pargr (gt_getr (gt, GTVXMIN)) + call pargr (gt_getr (gt, GTVXMAX)) + } + + case YVIEW: # yview: List or set y viewport. + call gargr (rval[1]) + call gargr (rval[2]) + if (nscan() == 3) { + call gt_setr (gt, GTVYMIN, rval[1]) + call gt_setr (gt, GTVYMAX, rval[2]) + } else { + call printf ("yview = %g %g\n") + call pargr (gt_getr (gt, GTVYMIN)) + call pargr (gt_getr (gt, GTVYMAX)) + } + + case XWINDOW: # xwindow: List or set x window. + call gargr (rval[1]) + call gargr (rval[2]) + if (nscan() == 3) { + call gt_setr (gt, GTXMIN, rval[1]) + call gt_setr (gt, GTXMAX, rval[2]) + } else { + call printf ("xwindow = %g %g\n") + call pargr (gt_getr (gt, GTXMIN)) + call pargr (gt_getr (gt, GTXMAX)) + } + + case YWINDOW: # ywindow: List or set y window. + call gargr (rval[1]) + call gargr (rval[2]) + if (nscan() == 3) { + call gt_setr (gt, GTYMIN, rval[1]) + call gt_setr (gt, GTYMAX, rval[2]) + } else { + call printf ("ywindow = %g %g\n") + call pargr (gt_getr (gt, GTYMIN)) + call pargr (gt_getr (gt, GTYMAX)) + } + + case SYSID: # sysid: Write SYSID string? + call gargb (bval) + if (nscan() == 2) + call gt_seti (gt, GTSYSID, btoi (bval)) + else { + call printf ("sysid = %b\n") + call pargi (gt_geti (gt, GTSYSID)) + } + + case PARAMETERS: # parameters: Set parameters string + call gargstr (cmd, SZ_LINE) + for (ip=1; IS_WHITE(cmd[ip]); ip=ip+1) + ; + call gt_sets (gt, GTPARAMS, cmd[ip]) + + case TITLE: # title: Set graph title + call gargstr (cmd, SZ_LINE) + for (ip=1; IS_WHITE(cmd[ip]); ip=ip+1) + ; + call gt_sets (gt, GTTITLE, cmd[ip]) + + case SUBTITLE: # subtitle: Set subtitle string + call gargstr (cmd, SZ_LINE) + for (ip=1; IS_WHITE(cmd[ip]); ip=ip+1) + ; + call gt_sets (gt, GTSUBTITLE, cmd[ip]) + + case COMMENTS: # comments: Set graph comments + call gargstr (cmd, SZ_LINE) + for (ip=1; IS_WHITE(cmd[ip]); ip=ip+1) + ; + call gt_sets (gt, GTCOMMENTS, cmd[ip]) + + case XLABEL: # xlabel: Set graph x label + call gargstr (cmd, SZ_LINE) + for (ip=1; IS_WHITE(cmd[ip]); ip=ip+1) + ; + call gt_sets (gt, GTXLABEL, cmd[ip]) + + case YLABEL: # ylabel: Set graph y label + call gargstr (cmd, SZ_LINE) + for (ip=1; IS_WHITE(cmd[ip]); ip=ip+1) + ; + call gt_sets (gt, GTYLABEL, cmd[ip]) + + case XUNITS: # xunits: Set graph x units + call gargstr (cmd, SZ_LINE) + for (ip=1; IS_WHITE(cmd[ip]); ip=ip+1) + ; + call gt_sets (gt, GTXUNITS, cmd[ip]) + + case YUNITS: # yunits: Set graph y units + call gargstr (cmd, SZ_LINE) + for (ip=1; IS_WHITE(cmd[ip]); ip=ip+1) + ; + call gt_sets (gt, GTYUNITS, cmd[ip]) + + case DRAWTITLE: # drawtitle: Draw title block? + call gargb (bval) + if (nscan() == 2) + call gt_seti (gt, GTDRAWTITLE, btoi (bval)) + else { + call printf ("drawtitle = %b\n") + call pargi (gt_geti (gt, GTDRAWTITLE)) + } + + case DRAWXLABELS: # drawxlabels: Draw x label block? + call gargb (bval) + if (nscan() == 2) + call gt_seti (gt, GTDRAWXLABELS, btoi (bval)) + else { + call printf ("drawxlabel = %b\n") + call pargi (gt_geti (gt, GTDRAWXLABELS)) + } + + case DRAWYLABELS: # drawylabels: Draw y label block? + call gargb (bval) + if (nscan() == 2) + call gt_seti (gt, GTDRAWYLABELS, btoi (bval)) + else { + call printf ("drawylabel = %b\n") + call pargi (gt_geti (gt, GTDRAWYLABELS)) + } + + case TYPE: # type: Graph type + call gargwrd (cmd, SZ_LINE) + if (nscan() == 2) + call gt_sets (gt, GTTYPE, cmd) + else { + call gt_gets (gt, GTTYPE, cmd, SZ_LINE) + call printf ("type = %s\n") + call pargstr (cmd) + } + + case MARK: # mark: Mark type + call gargwrd (cmd, SZ_LINE) + if (nscan() == 2) + call gt_sets (gt, GTMARK, cmd) + else { + call gt_gets (gt, GTMARK, cmd, SZ_LINE) + call printf ("mark = %s\n") + call pargstr (cmd) + } + + case LINE: # line: Line type + call gargi (ival) + if (nscan() == 2) + call gt_seti (gt, GTLINE, ival) + else { + call printf ("line = %s\n") + call pargi (gt_geti (gt, GTLINE)) + } + + case XSIZE: # xsize: List or set x mark size. + call gargr (rval[1]) + if (nscan() == 2) { + call gt_setr (gt, GTXSIZE, rval[1]) + } else { + call printf ("xsize = %g\n") + call pargr (gt_getr (gt, GTXSIZE)) + } + + + case YSIZE: # ysize: List or set y mark size. + call gargr (rval[1]) + if (nscan() == 2) { + call gt_setr (gt, GTYSIZE, rval[1]) + } else { + call printf ("ysize = %g\n") + call pargr (gt_getr (gt, GTYSIZE)) + } + + case COLOR: # color: line/mark color + call gargi (ival) + if (nscan() == 2) + call gt_seti (gt, GTCOLOR, ival) + else { + call printf ("color = %s\n") + call pargi (gt_geti (gt, GTCOLOR)) + } + + case XTRANSFORM: # xtransform: List or set ytransform. + call gargwrd (cmd, SZ_LINE) + if (nscan() == 2) + call gt_sets (gt, GTXTRAN, cmd) + else { + call gt_gets (gt, GTXTRAN, cmd, SZ_LINE) + call printf ("xtransform = %s\n") + call pargstr (cmd) + } + + case YTRANSFORM: # ytransform: List or set ytransform. + call gargwrd (cmd, SZ_LINE) + if (nscan() == 2) + call gt_sets (gt, GTYTRAN, cmd) + else { + call gt_gets (gt, GTYTRAN, cmd, SZ_LINE) + call printf ("ytransform = %s\n") + call pargstr (cmd) + } + + case XFLIP: # xflip: Toggle x flip flag + call gargb (bval) + if (nscan() == 2) + call gt_seti (gt, GTXFLIP, btoi (bval)) + else { + call printf ("xflip = %b\n") + call pargi (gt_geti (gt, GTXFLIP)) + } + + case YFLIP: # yflip: Toggle y flip flag + call gargb (bval) + if (nscan() == 2) + call gt_seti (gt, GTYFLIP, btoi (bval)) + else { + call printf ("yflip = %b\n") + call pargi (gt_geti (gt, GTYFLIP)) + } + + case TRANSPOSE: # transpose: Toggle transpose flag + if (gt_geti (gt, GTTRANSPOSE) == NO) + call gt_seti (gt, GTTRANSPOSE, YES) + else + call gt_seti (gt, GTTRANSPOSE, NO) + + case XFORMAT: # xformat: Set graph x format + call gargstr (cmd, SZ_LINE) + for (ip=1; IS_WHITE(cmd[ip]); ip=ip+1) + ; + call gt_sets (gt, GTXFORMAT, cmd[ip]) + + case YFORMAT: # yformat: Set graph y format + call gargstr (cmd, SZ_LINE) + for (ip=1; IS_WHITE(cmd[ip]); ip=ip+1) + ; + call gt_sets (gt, GTYFORMAT, cmd[ip]) + + case XBUF: # xbuf: List or set x buffer. + call gargr (rval[1]) + if (nscan() == 2) + call gt_setr (gt, GTXBUF, rval[1]) + else { + call printf ("xbuf = %g\n") + call pargr (gt_getr (gt, GTXBUF)) + } + + case YBUF: # ybuf: List or set y buffer. + call gargr (rval[1]) + if (nscan() == 2) + call gt_setr (gt, GTYBUF, rval[1]) + else { + call printf ("ybuf = %g\n") + call pargr (gt_getr (gt, GTYBUF)) + } + + case CLIP: # clip: autoscaling clipping + call gargr (rval[1]) + call gargr (rval[2]) + if (nscan() == 3) { + call gt_setr (gt, GTLCLIP, rval[1]) + call gt_setr (gt, GTHCLIP, rval[2]) + } else { + call printf ("clip = %g %g\n") + call pargr (gt_getr (gt, GTLCLIP)) + call pargr (gt_getr (gt, GTHCLIP)) + } + + case REDRAW: # redraw: Redraw the graph + newgraph = 1 + + case EXPAND: # :expand x1 x2 y1 y2 + call gargr (rval[1]) + call gargr (rval[2]) + call gargr (rval[3]) + call gargr (rval[4]) + if (nscan() == 5) { + if (rval[1] != gt_getr (gt, GTXMIN)) { + call gt_setr (gt, GTXMIN, rval[1]) + newgraph = 1 + } + if (rval[2] != gt_getr (gt, GTXMAX)) { + call gt_setr (gt, GTXMAX, rval[2]) + newgraph = 1 + } + if (rval[3] != gt_getr (gt, GTYMIN)) { + call gt_setr (gt, GTYMIN, rval[3]) + newgraph = 1 + } + if (rval[4] != gt_getr (gt, GTYMAX)) { + call gt_setr (gt, GTYMAX, rval[4]) + newgraph = 1 + } + } + + case SHIFT: # :shift x y + call gargr (x) + call gargr (y) + rval[1] = gt_getr (gt, GTXMIN) + rval[2] = gt_getr (gt, GTXMAX) + if (IS_INDEFR(x)) { + if (!IS_INDEFR(rval[1]) || !IS_INDEFR(rval[2])) { + call gt_setr (gt, GTXMIN, INDEFR) + call gt_setr (gt, GTXMAX, INDEFR) + newgraph = 1 + } + } else { + if (!IS_INDEFR(rval[1]) && !IS_INDEFR(rval[2])) { + rval[3] = rval[2] - rval[1] + rval[4] = x - (rval[1] + rval[2]) / 2 + if (abs (rval[4] / rval[3]) > 0.001) { + call gt_setr (gt, GTXMIN, rval[1] + rval[4]) + call gt_setr (gt, GTXMAX, rval[2] + rval[4]) + } + newgraph = 1 + } + } + + rval[1] = gt_getr (gt, GTYMIN) + rval[2] = gt_getr (gt, GTYMAX) + if (IS_INDEFR(y)) { + if (!IS_INDEFR(rval[1]) || !IS_INDEFR(rval[2])) { + call gt_setr (gt, GTYMIN, INDEFR) + call gt_setr (gt, GTYMAX, INDEFR) + newgraph = 1 + } + } else { + if (!IS_INDEFR(rval[1]) && !IS_INDEFR(rval[2])) { + rval[3] = rval[2] - rval[1] + rval[4] = y - (rval[1] + rval[2]) / 2 + if (abs (rval[4] / rval[3]) > 0.001) { + call gt_setr (gt, GTYMIN, rval[1] + rval[4]) + call gt_setr (gt, GTYMAX, rval[2] + rval[4]) + } + newgraph = 1 + } + } + + case WINDOW: # window: window x y wcs key cmd + call gargr (x) + call gargr (y) + call gargi (ip) + call gargwrd (cmd, SZ_LINE) + ival = cmd[1] + if (nscan() < 5) + return + if (ival == ':') + call gargwrd (cmd, SZ_LINE) + call gt_window1 (gt, gp, x, y, ip, ival, cmd, newgraph) + + case UIVALUES: # uivalues: send values to UI + call gt_uivalues (gp, gt) + + default: # Check for more colon command + call gt_colon1 (cmdstr, gp, gt, newgraph) + } +end + + +# Defined colon commands +define CMDS1 "|txup|txsize|txpath|txspacing|txhjustify|txvjustify|txfont\ + |txquality|txcolor|drawtitle|titlesize|titlejust|ntitlelines|aspect\ + |charsize|titlecolor|framecolor|drawaxes|setaxispos|axispos1|axispos2\ + |drawgrid|round|labelaxis|axislabelsize|drawticks|labelticks|nmajor\ + |nminor|majorlength|minorlength|majorwidth|minorwidth|axiswidth\ + |ticklabelsize|gridcolor|axislabelcolor|axiscolor|ticklabelcolor\ + |tickcolor|axes|ticks|colors|" + +define TXUP 1 # Text parameters +define TXSIZE 2 +define TXPATH 3 +define TXSPACING 4 +define TXHJUSTIFY 5 +define TXVJUSTIFY 6 +define TXFONT 7 +define TXQUALITY 8 +define TXCOLOR 9 + +define DRAWTITLE 10 # GLABAX, general parameters +define TITLESIZE 11 +define TITLEJUST 12 +define NTITLELINES 13 +define ASPECT 14 +define CHARSIZE 15 +define TITLECOLOR 16 +define FRAMECOLOR 17 + +define DRAWAXES 18 # GLABAX, x/y axis parameters +define SETAXISPOS 19 +define AXISPOS1 20 +define AXISPOS2 21 +define DRAWGRID 22 +define ROUND 23 +define LABELAXIS 24 +define AXISLABELSIZE 25 +define DRAWTICKS 26 +define LABELTICKS 27 +define NMAJOR 28 +define NMINOR 29 +define MAJORLENGTH 30 +define MINORLENGTH 31 +define MAJORWIDTH 32 +define MINORWIDTH 33 +define AXISWIDTH 34 +define TICKLABELSIZE 35 +define GRIDCOLOR 36 +define AXISLABELCOLOR 37 +define AXISCOLOR 38 +define TICKLABELCOLOR 39 +define TICKCOLOR 40 + +define AXES 41 # Grouped parameters +define TICKS 42 +define COLORS 43 + + +# GT_COLON1 -- Interpret colon commands. + +procedure gt_colon1 (cmdstr, gp, gt, newgraph) + +char cmdstr[ARB] # Command string +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +int newgraph # Update graph? + +bool bval +real rval[12] +pointer sp, cmd +int ncmd, btoi(), nscan(), strdic() + +begin + # All GTOOLS commands start with '/'. + if (cmdstr[1] != '/') + return + + # Parse the command string matched against a dictionary. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + call sscan (cmdstr[2]) + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, CMDS1) + + # Get arguments and return if there are insufficient arguments. + if (ncmd < DRAWAXES) { + call gargr (rval[1]) + if (nscan() != 2) { + call sfree (sp) + return + } + } else if (ncmd < AXES) { + switch (ncmd) { + case DRAWAXES: + call gargwrd (Memc[cmd], SZ_LINE) + rval[1] = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GT_XAXES) + call gargwrd (Memc[cmd], SZ_LINE) + rval[2] = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GT_YAXES) + case DRAWGRID, ROUND, LABELAXIS, DRAWTICKS, LABELTICKS: + call gargb (bval) + rval[1] = btoi (bval) + call gargb (bval) + rval[2] = btoi (bval) + default: + call gargr (rval[1]) + call gargr (rval[2]) + } + if (nscan() != 3) { + call sfree (sp) + return + } + } + + # Switch on the command and parse the arguments. + switch (ncmd) { + case TXUP: + Memi[gt+GT_TXUP] = nint (rval[1]) + case TXSIZE: + Memr[P2R(gt+GT_TXSIZE)] = rval[1] + case TXPATH: + Memi[gt+GT_TXPATH] = nint (rval[1]) + case TXSPACING: + Memr[P2R(gt+GT_TXSPACING)] = rval[1] + case TXHJUSTIFY: + Memi[gt+GT_TXHJUSTIFY] = nint (rval[1]) + case TXVJUSTIFY: + Memi[gt+GT_TXVJUSTIFY] = nint (rval[1]) + case TXFONT: + Memi[gt+GT_TXFONT] = nint (rval[1]) + case TXQUALITY: + Memi[gt+GT_TXQUALITY] = nint (rval[1]) + case TXCOLOR: + Memi[gt+GT_TXCOLOR] = nint (rval[1]) + + case DRAWTITLE: + Memi[gt+GT_DRAWTITLE] = nint (rval[1]) + case TITLESIZE: + Memr[P2R(gt+GT_TITLESIZE)] = rval[1] + case TITLEJUST: + Memi[gt+GT_TITLEJUST] = nint (rval[1]) + case NTITLELINES: + Memi[gt+GT_NTITLELINES] = nint (rval[1]) + case ASPECT: + Memr[P2R(gt+GT_ASPECT)] = rval[1] + case CHARSIZE: + Memr[P2R(gt+GT_CHARSIZE)] = rval[1] + case TITLECOLOR: + Memi[gt+GT_TITLECOLOR] = nint (rval[1]) + case FRAMECOLOR: + Memi[gt+GT_FRAMECOLOR] = nint (rval[1]) + + case DRAWAXES: + if (rval[1] > 0) + Memi[gt+GT_XDRAWAXES] = nint (rval[1]) - 1 + if (rval[2] > 0) + Memi[gt+GT_YDRAWAXES] = nint (rval[2]) - 1 + case SETAXISPOS: + Memi[gt+GT_XSETAXISPOS] = nint (rval[1]) + Memi[gt+GT_YSETAXISPOS] = nint (rval[2]) + case AXISPOS1: + Memr[P2R(gt+GT_XAXISPOS1)] = rval[1] + Memr[P2R(gt+GT_YAXISPOS1)] = rval[2] + case AXISPOS2: + Memr[P2R(gt+GT_XAXISPOS2)] = rval[1] + Memr[P2R(gt+GT_YAXISPOS2)] = rval[2] + case DRAWGRID: + Memi[gt+GT_XDRAWGRID] = nint (rval[1]) + Memi[gt+GT_YDRAWGRID] = nint (rval[2]) + case ROUND: + Memi[gt+GT_XROUND] = nint (rval[1]) + Memi[gt+GT_YROUND] = nint (rval[2]) + case LABELAXIS: + Memi[gt+GT_XLABELAXIS] = nint (rval[1]) + Memi[gt+GT_YLABELAXIS] = nint (rval[2]) + case AXISLABELSIZE: + Memr[P2R(gt+GT_XAXISLABELSIZE)] = rval[1] + Memr[P2R(gt+GT_YAXISLABELSIZE)] = rval[2] + case DRAWTICKS: + Memi[gt+GT_XDRAWTICKS] = nint (rval[1]) + Memi[gt+GT_YDRAWTICKS] = nint (rval[2]) + case LABELTICKS: + Memi[gt+GT_XLABELTICKS] = nint (rval[1]) + Memi[gt+GT_YLABELTICKS] = nint (rval[2]) + case NMAJOR: + Memi[gt+GT_XNMAJOR] = nint (rval[1]) + Memi[gt+GT_YNMAJOR] = nint (rval[2]) + case NMINOR: + Memi[gt+GT_XNMINOR] = nint (rval[1]) + Memi[gt+GT_YNMINOR] = nint (rval[2]) + case MAJORLENGTH: + Memr[P2R(gt+GT_XMAJORLENGTH)] = rval[1] + Memr[P2R(gt+GT_YMAJORLENGTH)] = rval[2] + case MINORLENGTH: + Memr[P2R(gt+GT_XMINORLENGTH)] = rval[1] + Memr[P2R(gt+GT_YMINORLENGTH)] = rval[2] + case MAJORWIDTH: + Memr[P2R(gt+GT_XMAJORWIDTH)] = rval[1] + Memr[P2R(gt+GT_YMAJORWIDTH)] = rval[2] + case MINORWIDTH: + Memr[P2R(gt+GT_XMINORWIDTH)] = rval[1] + Memr[P2R(gt+GT_YMINORWIDTH)] = rval[2] + case AXISWIDTH: + Memr[P2R(gt+GT_XAXISWIDTH)] = rval[1] + Memr[P2R(gt+GT_YAXISWIDTH)] = rval[2] + case TICKLABELSIZE: + Memr[P2R(gt+GT_XTICKLABELSIZE)] = rval[1] + Memr[P2R(gt+GT_YTICKLABELSIZE)] = rval[2] + case GRIDCOLOR: + Memi[gt+GT_XGRIDCOLOR] = nint (rval[1]) + Memi[gt+GT_YGRIDCOLOR] = nint (rval[2]) + case AXISLABELCOLOR: + Memi[gt+GT_XAXISLABELCOLOR] = nint (rval[1]) + Memi[gt+GT_YAXISLABELCOLOR] = nint (rval[2]) + case AXISCOLOR: + Memi[gt+GT_XAXISCOLOR] = nint (rval[1]) + Memi[gt+GT_YAXISCOLOR] = nint (rval[2]) + case TICKLABELCOLOR: + Memi[gt+GT_XTICKLABELCOLOR] = nint (rval[1]) + Memi[gt+GT_YTICKLABELCOLOR] = nint (rval[2]) + case TICKCOLOR: + Memi[gt+GT_XTICKCOLOR] = nint (rval[1]) + Memi[gt+GT_YTICKCOLOR] = nint (rval[2]) + + case AXES: + call gargwrd (Memc[cmd], SZ_LINE) + rval[1] = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GT_XAXES) + call gargr (rval[2]) + call gargb (bval) + rval[3] = btoi (bval) + call gargwrd (Memc[cmd], SZ_LINE) + rval[4] = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GT_XAXES) + call gargr (rval[5]) + call gargb (bval) + rval[6] = btoi (bval) + if (nscan() == 7) { + Memi[gt+GT_XDRAWAXES] = nint (rval[1]) + Memr[P2R(gt+GT_XAXISWIDTH)] = rval[2] + Memr[P2R(gt+GT_XMAJORWIDTH)] = rval[2] + Memr[P2R(gt+GT_XMINORWIDTH)] = rval[2] + Memi[gt+GT_XDRAWGRID] = nint (rval[3]) + Memi[gt+GT_YDRAWAXES] = nint (rval[4]) + Memr[P2R(gt+GT_YAXISWIDTH)] = rval[5] + Memr[P2R(gt+GT_YMAJORWIDTH)] = rval[5] + Memr[P2R(gt+GT_YMINORWIDTH)] = rval[5] + Memi[gt+GT_YDRAWGRID] = nint (rval[6]) + } + case TICKS: + call gargb (bval) + rval[1] = btoi (bval) + call gargb (bval) + rval[2] = btoi (bval) + call gargr (rval[3]) + call gargr (rval[4]) + call gargb (bval) + rval[5] = btoi (bval) + call gargb (bval) + rval[6] = btoi (bval) + call gargr (rval[7]) + call gargr (rval[8]) + if (nscan() == 9) { + Memi[gt+GT_XDRAWTICKS] = nint (rval[1]) + Memi[gt+GT_XLABELTICKS] = nint (rval[2]) + Memi[gt+GT_XNMAJOR] = nint (rval[3]) + Memi[gt+GT_XNMINOR] = nint (rval[4]) + Memi[gt+GT_YDRAWTICKS] = nint (rval[5]) + Memi[gt+GT_YLABELTICKS] = nint (rval[6]) + Memi[gt+GT_YNMAJOR] = nint (rval[7]) + Memi[gt+GT_YNMINOR] = nint (rval[8]) + } + case COLORS: + call gargr (rval[1]) + call gargr (rval[2]) + call gargr (rval[3]) + call gargr (rval[4]) + call gargr (rval[5]) + call gargr (rval[6]) + call gargr (rval[7]) + call gargr (rval[8]) + call gargr (rval[9]) + call gargr (rval[10]) + call gargr (rval[11]) + call gargr (rval[12]) + if (nscan() == 13) { + Memi[gt+GT_FRAMECOLOR] = nint (rval[1]) + Memi[gt+GT_TITLECOLOR] = nint (rval[2]) + Memi[gt+GT_XGRIDCOLOR] = nint (rval[3]) + Memi[gt+GT_XAXISLABELCOLOR] = nint (rval[4]) + Memi[gt+GT_XAXISCOLOR] = nint (rval[5]) + Memi[gt+GT_XTICKLABELCOLOR] = nint (rval[6]) + Memi[gt+GT_XTICKCOLOR] = nint (rval[7]) + Memi[gt+GT_YGRIDCOLOR] = nint (rval[8]) + Memi[gt+GT_YAXISLABELCOLOR] = nint (rval[9]) + Memi[gt+GT_YAXISCOLOR] = nint (rval[10]) + Memi[gt+GT_YTICKLABELCOLOR] = nint (rval[11]) + Memi[gt+GT_YTICKCOLOR] = nint (rval[12]) + } + } + + call sfree (sp) +end diff --git a/pkg/xtools/gtools/gtcopy.x b/pkg/xtools/gtools/gtcopy.x new file mode 100644 index 00000000..5c79da9e --- /dev/null +++ b/pkg/xtools/gtools/gtcopy.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gtools.h" + +# GT_COPY -- Copy values of one structure to another. + +procedure gt_copy (gt1, gt2) + +pointer gt1, gt2 + +int len, strlen() +pointer gt_init() + +begin + if (gt1 == NULL) + call error (0, "gt_copy: Undefined gtools structure") + + if (gt2 == NULL) + gt2 = gt_init () + else { + call mfree (GT_PARAMS(gt2), TY_CHAR) + call mfree (GT_TITLE(gt2), TY_CHAR) + call mfree (GT_SUBTITLE(gt2), TY_CHAR) + call mfree (GT_COMMENTS(gt2), TY_CHAR) + call mfree (GT_XLABEL(gt2), TY_CHAR) + call mfree (GT_YLABEL(gt2), TY_CHAR) + call mfree (GT_XUNITS(gt2), TY_CHAR) + call mfree (GT_YUNITS(gt2), TY_CHAR) + call mfree (GT_XFORMAT(gt2), TY_CHAR) + call mfree (GT_YFORMAT(gt2), TY_CHAR) + } + + call amovi (Memi[gt1], Memi[gt2], LEN_GT) + + if (GT_PARAMS(gt1) != NULL) { + len = strlen (Memc[GT_PARAMS(gt1)]) + call malloc (GT_PARAMS(gt2), len, TY_CHAR) + call strcpy (Memc[GT_PARAMS(gt1)], Memc[GT_PARAMS(gt2)], len) + } + if (GT_TITLE(gt1) != NULL) { + len = strlen (Memc[GT_TITLE(gt1)]) + call malloc (GT_TITLE(gt2), len, TY_CHAR) + call strcpy (Memc[GT_TITLE(gt1)], Memc[GT_TITLE(gt2)], len) + } + if (GT_SUBTITLE(gt1) != NULL) { + len = strlen (Memc[GT_SUBTITLE(gt1)]) + call malloc (GT_SUBTITLE(gt2), len, TY_CHAR) + call strcpy (Memc[GT_SUBTITLE(gt1)], Memc[GT_SUBTITLE(gt2)], len) + } + if (GT_COMMENTS(gt1) != NULL) { + len = strlen (Memc[GT_COMMENTS(gt1)]) + call malloc (GT_COMMENTS(gt2), len, TY_CHAR) + call strcpy (Memc[GT_COMMENTS(gt1)], Memc[GT_COMMENTS(gt2)], len) + } + if (GT_XLABEL(gt1) != NULL) { + len = strlen (Memc[GT_XLABEL(gt1)]) + call malloc (GT_XLABEL(gt2), len, TY_CHAR) + call strcpy (Memc[GT_XLABEL(gt1)], Memc[GT_XLABEL(gt2)], len) + } + if (GT_YLABEL(gt1) != NULL) { + len = strlen (Memc[GT_YLABEL(gt1)]) + call malloc (GT_YLABEL(gt2), len, TY_CHAR) + call strcpy (Memc[GT_YLABEL(gt1)], Memc[GT_YLABEL(gt2)], len) + } + if (GT_XUNITS(gt1) != NULL) { + len = strlen (Memc[GT_XUNITS(gt1)]) + call malloc (GT_XUNITS(gt2), len, TY_CHAR) + call strcpy (Memc[GT_XUNITS(gt1)], Memc[GT_XUNITS(gt2)], len) + } + if (GT_YUNITS(gt1) != NULL) { + len = strlen (Memc[GT_YUNITS(gt1)]) + call malloc (GT_YUNITS(gt2), len, TY_CHAR) + call strcpy (Memc[GT_YUNITS(gt1)], Memc[GT_YUNITS(gt2)], len) + } + if (GT_XFORMAT(gt1) != NULL) { + len = strlen (Memc[GT_XFORMAT(gt1)]) + call malloc (GT_XFORMAT(gt2), len, TY_CHAR) + call strcpy (Memc[GT_XFORMAT(gt1)], Memc[GT_XFORMAT(gt2)], len) + } + if (GT_YFORMAT(gt1) != NULL) { + len = strlen (Memc[GT_YFORMAT(gt1)]) + call malloc (GT_YFORMAT(gt2), len, TY_CHAR) + call strcpy (Memc[GT_YFORMAT(gt1)], Memc[GT_YFORMAT(gt2)], len) + } +end diff --git a/pkg/xtools/gtools/gtctran.x b/pkg/xtools/gtools/gtctran.x new file mode 100644 index 00000000..1b62688f --- /dev/null +++ b/pkg/xtools/gtools/gtctran.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GT_XCTRAN -- Transform x between two WCS. Return new value as a function. + +real procedure gt_xctran (gp, x1, wcs1, wcs2) + +pointer gp # GIO pointer +real x1 # X value to be transformed +int wcs1 # Input WCS +int wcs2 # Output WCS + +real x2, y2 + +begin + call gctran (gp, x1, 0., x2, y2, wcs1, wcs2) + return (x2) +end + + +# GT_YCTRAN -- Transform y between two WCS. Return new value as a function. + +real procedure gt_yctran (gp, y1, wcs1, wcs2) + +pointer gp # GIO pointer +real y1 # Y value to be transformed +int wcs1 # Input WCS +int wcs2 # Output WCS + +real x2, y2 + +begin + call gctran (gp, 0., y1, x2, y2, wcs1, wcs2) + return (y2) +end diff --git a/pkg/xtools/gtools/gtcur.x b/pkg/xtools/gtools/gtcur.x new file mode 100644 index 00000000..7103bf9c --- /dev/null +++ b/pkg/xtools/gtools/gtcur.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GT_GCUR -- Interface to clgcur to confirm EOF, map key 'q' to EOF. + +int procedure gt_gcur (cur, wx, wy, wcs, key, cmd, sz_cmd) + +char cur[ARB] # Cursor parameter +real wx, wy # Cursor position +int wcs, key # WCS and cursor key +char cmd[sz_cmd] # Command string +int sz_cmd # Size of command string + +int curval, clgcur() + +begin + curval = clgcur (cur, wx, wy, wcs, key, cmd, sz_cmd) + if (key == 'q') + curval = EOF + + return (curval) +end diff --git a/pkg/xtools/gtools/gtcur1.x b/pkg/xtools/gtools/gtcur1.x new file mode 100644 index 00000000..edb42299 --- /dev/null +++ b/pkg/xtools/gtools/gtcur1.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gtools.h" + +# GT_GCUR1 -- Interface to clgcur to confirm EOF, map key 'q' to EOF. +# Transposes X and Y if needed. + +int procedure gt_gcur1 (gt, cur, wx, wy, wcs, key, cmd, sz_cmd) + +pointer gt # GTOOLS pointer +char cur[ARB] # Cursor parameter +real wx, wy # Cursor position +int wcs, key # WCS and cursor key +char cmd[sz_cmd] # Command string +int sz_cmd # Size of command string + +int curval, clgcur() +real temp + +begin + curval = clgcur (cur, wx, wy, wcs, key, cmd, sz_cmd) + + if (curval == EOF) { + curval = clgcur (cur, wx, wy, wcs, key, cmd, sz_cmd) + if (curval != EOF) { + if (key == 'q') + curval = EOF + } + } else if (key == 'q') + curval = EOF + + if (GT_TRANSPOSE(gt) == YES) { + temp = wx + wx = wy + wy = temp + } + return (curval) +end diff --git a/pkg/xtools/gtools/gtfree.x b/pkg/xtools/gtools/gtfree.x new file mode 100644 index 00000000..da4bec03 --- /dev/null +++ b/pkg/xtools/gtools/gtfree.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gtools.h" + +# GT_FREE -- Free extended graphics tools structure. + +procedure gt_free (gt) + +pointer gt # Graphic tools pointer + +begin + if (gt == NULL) + return + + call mfree (GT_PARAMS(gt), TY_CHAR) + call mfree (GT_TITLE(gt), TY_CHAR) + call mfree (GT_SUBTITLE(gt), TY_CHAR) + call mfree (GT_COMMENTS(gt), TY_CHAR) + call mfree (GT_XLABEL(gt), TY_CHAR) + call mfree (GT_YLABEL(gt), TY_CHAR) + call mfree (GT_XUNITS(gt), TY_CHAR) + call mfree (GT_YUNITS(gt), TY_CHAR) + call mfree (GT_XFORMAT(gt), TY_CHAR) + call mfree (GT_YFORMAT(gt), TY_CHAR) + call mfree (gt, TY_STRUCT) +end diff --git a/pkg/xtools/gtools/gtget.x b/pkg/xtools/gtools/gtget.x new file mode 100644 index 00000000..8274dab9 --- /dev/null +++ b/pkg/xtools/gtools/gtget.x @@ -0,0 +1,210 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include "gtools.h" + +# GT_GETI -- Set integer parameters. + +int procedure gt_geti (gt, param) + +pointer gt # GTOOLS pointer +int param # Parameter to set + +begin + switch (param) { + case GTLINE: + return (GT_LINE(gt)) + case GTTRANSPOSE: + return (GT_TRANSPOSE(gt)) + case GTSYSID: + return (GT_SYSID(gt)) + case GTCOLOR: + return (GT_COLOR(gt)) + case GTXFLIP: + return (GT_XFLIP(gt)) + case GTYFLIP: + return (GT_YFLIP(gt)) + case GTDRAWTITLE: + return (GT_DRWTITLE(gt)) + case GTDRAWXLABELS: + return (GT_DRWXLABELS(gt)) + case GTDRAWYLABELS: + return (GT_DRWYLABELS(gt)) + } +end + + +# GT_GETR -- Set real parameters. + +real procedure gt_getr (gt, param) + +pointer gt # GTOOLS pointer +int param # Parameter to set + +begin + switch (param) { + case GTVXMIN: + return (GT_VXMIN(gt)) + case GTVXMAX: + return (GT_VXMAX(gt)) + case GTVYMIN: + return (GT_VYMIN(gt)) + case GTVYMAX: + return (GT_VYMAX(gt)) + case GTXMIN: + if (GT_XFLIP(gt) == NO) + return (GT_XMIN(gt)) + else + return (GT_XMAX(gt)) + case GTXMAX: + if (GT_XFLIP(gt) == NO) + return (GT_XMAX(gt)) + else + return (GT_XMIN(gt)) + case GTYMIN: + if (GT_YFLIP(gt) == NO) + return (GT_YMIN(gt)) + else + return (GT_YMAX(gt)) + case GTYMAX: + if (GT_YFLIP(gt) == NO) + return (GT_YMAX(gt)) + else + return (GT_YMIN(gt)) + case GTXBUF: + return (GT_XBUF(gt)) + case GTYBUF: + return (GT_YBUF(gt)) + case GTLCLIP: + return (GT_LCLIP(gt)) + case GTHCLIP: + return (GT_HCLIP(gt)) + case GTXSIZE: + return (GT_XSIZE(gt)) + case GTYSIZE: + return (GT_YSIZE(gt)) + } +end + + +# GT_GETS -- Get string parameters. + +procedure gt_gets (gt, param, str, sz_str) + +pointer gt # GTOOLS pointer +int param # Parameter to set +char str[sz_str] # String +int sz_str # Size of string + +begin + str[1] = EOS + switch (param) { + case GTPARAMS: + if (GT_PARAMS(gt) != NULL) + call strcpy (Memc[GT_PARAMS(gt)], str, sz_str) + case GTTITLE: + if (GT_TITLE(gt) != NULL) + call strcpy (Memc[GT_TITLE(gt)], str, sz_str) + case GTSUBTITLE: + if (GT_SUBTITLE(gt) != NULL) + call strcpy (Memc[GT_SUBTITLE(gt)], str, sz_str) + case GTCOMMENTS: + if (GT_COMMENTS(gt) != NULL) + call strcpy (Memc[GT_COMMENTS(gt)], str, sz_str) + case GTXLABEL: + if (GT_XLABEL(gt) != NULL) + call strcpy (Memc[GT_XLABEL(gt)], str, sz_str) + case GTYLABEL: + if (GT_YLABEL(gt) != NULL) + call strcpy (Memc[GT_YLABEL(gt)], str, sz_str) + case GTXUNITS: + if (GT_XUNITS(gt) != NULL) + call strcpy (Memc[GT_XUNITS(gt)], str, sz_str) + case GTYUNITS: + if (GT_YUNITS(gt) != NULL) + call strcpy (Memc[GT_YUNITS(gt)], str, sz_str) + case GTXFORMAT: + if (GT_XFORMAT(gt) != NULL) + call strcpy (Memc[GT_XFORMAT(gt)], str, sz_str) + case GTYFORMAT: + if (GT_YFORMAT(gt) != NULL) + call strcpy (Memc[GT_YFORMAT(gt)], str, sz_str) + case GTXTRAN: + switch (GT_XTRAN(gt)) { + case GW_LINEAR: + call strcpy ("linear", str, sz_str) + case GW_ELOG: + call strcpy ("logarithmic", str, sz_str) + } + case GTYTRAN: + switch (GT_YTRAN(gt)) { + case GW_LINEAR: + call strcpy ("linear", str, sz_str) + case GW_ELOG: + call strcpy ("logarithmic", str, sz_str) + } + case GTTYPE: + #switch (GT_TYPE(gt)) { + #case 1: + # call strcpy ("mark", str, sz_str) + #case 2: + # call strcpy ("line", str, sz_str) + #case 3: + # call strcpy ("histogram", str, sz_str) + #} + switch (GT_TYPE(gt)) { + case 1: + switch (GT_MARK(gt)) { + case GM_POINT: + call strcpy ("point", str, sz_str) + case GM_BOX: + call strcpy ("box", str, sz_str) + case GM_PLUS: + call strcpy ("plus", str, sz_str) + case GM_CROSS: + call strcpy ("cross", str, sz_str) + case GM_DIAMOND: + call strcpy ("diamond", str, sz_str) + case GM_HLINE: + call strcpy ("hline", str, sz_str) + case GM_VLINE: + call strcpy ("vline", str, sz_str) + case GM_HEBAR: + call strcpy ("hebar", str, sz_str) + case GM_VEBAR: + call strcpy ("vebar", str, sz_str) + case GM_CIRCLE: + call strcpy ("circle", str, sz_str) + } + case 2: + call sprintf (str, sz_str, "line%d") + call pargi (GT_LINE(gt)) + case 3: + call sprintf (str, sz_str, "hist%d") + call pargi (GT_LINE(gt)) + } + case GTMARK: + switch (GT_MARK(gt)) { + case GM_POINT: + call strcpy ("point", str, sz_str) + case GM_BOX: + call strcpy ("box", str, sz_str) + case GM_PLUS: + call strcpy ("plus", str, sz_str) + case GM_CROSS: + call strcpy ("cross", str, sz_str) + case GM_DIAMOND: + call strcpy ("diamond", str, sz_str) + case GM_HLINE: + call strcpy ("hline", str, sz_str) + case GM_VLINE: + call strcpy ("vline", str, sz_str) + case GM_HEBAR: + call strcpy ("hebar", str, sz_str) + case GM_VEBAR: + call strcpy ("vebar", str, sz_str) + case GM_CIRCLE: + call strcpy ("circle", str, sz_str) + } + } +end diff --git a/pkg/xtools/gtools/gtgui.x b/pkg/xtools/gtools/gtgui.x new file mode 100644 index 00000000..16981ee3 --- /dev/null +++ b/pkg/xtools/gtools/gtgui.x @@ -0,0 +1,160 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include "gtools.h" + +# GT_UIVALUES -- Send UI parameters values. + +procedure gt_uivalues (gp, gt) + +pointer gp # GIO pointer +pointer gt # GTOOLS pointer + +int fd, stropen() +pointer sp, msg, str1, str2 + +begin + if (gt == NULL) + return + + call smark (sp) + call salloc (msg, 20 * SZ_LINE, TY_CHAR) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + fd = stropen (Memc[msg], 20 * SZ_LINE, WRITE_ONLY) + + # SysID + call fprintf (fd, "%b ") + call pargi (GT_SYSID(gt)) + + # Titles + call fprintf (fd, "\"%s\" \"%s\" \"%s\" \"%s\" \"%s\" \"%s\" ") + if (GT_TITLE(gt) == NULL) + call pargstr ("") + else + call pargstr (Memc[GT_TITLE(gt)]) + if (GT_SUBTITLE(gt) == NULL) + call pargstr ("") + else + call pargstr (Memc[GT_SUBTITLE(gt)]) + if (GT_XLABEL(gt) == NULL) + call pargstr ("") + else + call pargstr (Memc[GT_XLABEL(gt)]) + if (GT_XUNITS(gt) == NULL) + call pargstr ("") + else + call pargstr (Memc[GT_XUNITS(gt)]) + if (GT_YLABEL(gt) == NULL) + call pargstr ("") + else + call pargstr (Memc[GT_YLABEL(gt)]) + if (GT_YUNITS(gt) == NULL) + call pargstr ("") + else + call pargstr (Memc[GT_YUNITS(gt)]) + + # Viewport + call fprintf (fd, "%4.2f %4.2f %4.2f %4.2f ") + call pargr (GT_VXMIN(gt)) + call pargr (GT_VXMAX(gt)) + call pargr (GT_VYMIN(gt)) + call pargr (GT_VYMAX(gt)) + + # Window + call fprintf (fd, "%4.2f %4.2f %4.2f %4.2f ") + call pargr (GT_XMIN(gt)) + call pargr (GT_XMAX(gt)) + call pargr (GT_YMIN(gt)) + call pargr (GT_YMAX(gt)) + + # Gtools + call fprintf (fd, "%b %b %b %4.2f %4.2f %g %g ") + call pargi (GT_TRANSPOSE(gt)) + call pargi (GT_XFLIP(gt)) + call pargi (GT_YFLIP(gt)) + call pargr (GT_XBUF(gt)) + call pargr (GT_YBUF(gt)) + call pargr (GT_LCLIP(gt)) + call pargr (GT_HCLIP(gt)) + + # Plot types + call gt_gets (gt, GTTYPE, Memc[str1], SZ_LINE) + call fprintf (fd, "%s %g %g %d ") + call pargstr (Memc[str1]) + call pargr (GT_XSIZE(gt)) + call pargr (GT_YSIZE(gt)) + call pargi (GT_COLOR(gt)) + + # Axes + call gt_gets (gt, GTXTRAN, Memc[str1], SZ_LINE) + call gt_gets (gt, GTYTRAN, Memc[str2], SZ_LINE) + call fprintf (fd, "%s %s %g %g %s %s %b %b ") + switch (Memi[gt+GT_XDRAWAXES]) { + case 0: + call pargstr ("none") + case 1: + call pargstr ("bottom") + case 2: + call pargstr ("top") + case 3: + call pargstr ("both") + } + switch (Memi[gt+GT_YDRAWAXES]) { + case 0: + call pargstr ("none") + case 1: + call pargstr ("left") + case 2: + call pargstr ("right") + case 3: + call pargstr ("both") + } + call pargr (Memr[P2R(gt+GT_XAXISWIDTH)]) + call pargr (Memr[P2R(gt+GT_YAXISWIDTH)]) + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargi (Memi[gt+GT_XDRAWGRID]) + call pargi (Memi[gt+GT_YDRAWGRID]) + + # Ticks + call fprintf (fd, "%b %b %d %d %d %d %b %b \"%s\" \"%s\" ") + call pargi (Memi[gt+GT_XDRAWTICKS]) + call pargi (Memi[gt+GT_YDRAWTICKS]) + call pargi (Memi[gt+GT_XNMAJOR]) + call pargi (Memi[gt+GT_YNMAJOR]) + call pargi (Memi[gt+GT_XNMINOR]) + call pargi (Memi[gt+GT_YNMINOR]) + call pargi (Memi[gt+GT_XLABELTICKS]) + call pargi (Memi[gt+GT_YLABELTICKS]) + if (GT_XFORMAT(gt) == NULL) + call pargstr ("") + else + call pargstr (Memc[GT_XFORMAT(gt)]) + if (GT_YFORMAT(gt) == NULL) + call pargstr ("") + else + call pargstr (Memc[GT_YFORMAT(gt)]) + + # Colors + call fprintf (fd, "%d %d %d %d %d %d %d %d %d %d %d %d %d") + call pargi (Memi[gt+GT_FRAMECOLOR]) + call pargi (Memi[gt+GT_TITLECOLOR]) + call pargi (Memi[gt+GT_XGRIDCOLOR]) + call pargi (Memi[gt+GT_YGRIDCOLOR]) + call pargi (Memi[gt+GT_XAXISLABELCOLOR]) + call pargi (Memi[gt+GT_YAXISLABELCOLOR]) + call pargi (Memi[gt+GT_XAXISCOLOR]) + call pargi (Memi[gt+GT_YAXISCOLOR]) + call pargi (Memi[gt+GT_XTICKLABELCOLOR]) + call pargi (Memi[gt+GT_YTICKLABELCOLOR]) + call pargi (Memi[gt+GT_XTICKCOLOR]) + call pargi (Memi[gt+GT_YTICKCOLOR]) + call pargi (Memi[gt+GT_TXCOLOR]) + + call strclose (fd) + call gmsg (gp, "gtvalues", Memc[msg]) + + call sfree (sp) +end diff --git a/pkg/xtools/gtools/gthelp.x b/pkg/xtools/gtools/gthelp.x new file mode 100644 index 00000000..6267ced4 --- /dev/null +++ b/pkg/xtools/gtools/gthelp.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GT_HELP -- Page graphics help from a file. +# This routine should not be called anymore. + +procedure gt_help (file) + +char file[ARB] # File to be paged + +begin + call pagefile (file, "") +end diff --git a/pkg/xtools/gtools/gtinit.x b/pkg/xtools/gtools/gtinit.x new file mode 100644 index 00000000..11e0c5bb --- /dev/null +++ b/pkg/xtools/gtools/gtinit.x @@ -0,0 +1,164 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include "gtools.h" + +# GT_INIT1 -- Open the GTOOLS pointer. + +pointer procedure gt_init1 (gp) + +pointer gp +pointer gt + +pointer gt_init() +errchk gt_init, gt_ireset + +begin + # Initialize the graphics. + + gt = gt_init() + call gt_ireset (gp, gt) + + return (gt) +end + + +# GT_INIT -- Allocate and initialize GTOOLS pointer. +# +# This is an older version. To properly set things either gt_ireset +# should be called after gt_init or use the new gt_init1. + +pointer procedure gt_init () + +pointer gt + +begin + # Initialize the graphics. + + call calloc (gt, LEN_GT, TY_STRUCT) + GT_VXMIN(gt) = INDEFR + GT_VXMAX(gt) = INDEFR + GT_VYMIN(gt) = INDEFR + GT_VYMAX(gt) = INDEFR + GT_XMIN(gt) = INDEFR + GT_XMAX(gt) = INDEFR + GT_YMIN(gt) = INDEFR + GT_YMAX(gt) = INDEFR + call gt_sets (gt, GTXTRAN, "linear") + call gt_sets (gt, GTYTRAN, "linear") + GT_XSIZE(gt) = 2. + GT_YSIZE(gt) = 2. + GT_SYSID(gt) = YES + GT_PARAMS(gt) = NULL + GT_TITLE(gt) = NULL + GT_SUBTITLE(gt) = NULL + GT_COMMENTS(gt) = NULL + GT_XLABEL(gt) = NULL + GT_YLABEL(gt) = NULL + GT_XUNITS(gt) = NULL + GT_YUNITS(gt) = NULL + GT_DRWTITLE(gt) = YES + GT_DRWXLABELS(gt) = YES + GT_DRWYLABELS(gt) = YES + GT_XFORMAT(gt) = NULL + GT_YFORMAT(gt) = NULL + GT_XBUF(gt) = .03 + GT_YBUF(gt) = .03 + GT_LCLIP(gt) = 0. + GT_HCLIP(gt) = 0. + GT_XFLIP(gt) = NO + GT_YFLIP(gt) = NO + GT_TRANSPOSE(gt) = NO + call gt_sets (gt, GTTYPE, "mark") + call gt_sets (gt, GTMARK, "plus") + call gt_seti (gt, GTLINE, 1) + call gt_seti (gt, GTCOLOR, 1) + + GT_RESET(gt) = NO + + return (gt) +end + + +# GT_IRESET -- Initialize GTOOLS values from GP pointer. + +procedure gt_ireset (gp, gt) + +pointer gp #I GIO pointer +pointer gt #I GTOOLS pointer + +int gstati() +real gstatr() + +begin + Memi[gt+GT_TXUP] = gstati (gp, G_TXUP) + Memr[P2R(gt+GT_TXSIZE)] = gstatr (gp, G_TXSIZE) + Memi[gt+GT_TXPATH] = gstati (gp, G_TXPATH) + Memr[P2R(gt+GT_TXSPACING)] = gstatr (gp, G_TXSPACING) + Memi[gt+GT_TXHJUSTIFY] = gstati (gp, G_TXHJUSTIFY) + Memi[gt+GT_TXVJUSTIFY] = gstati (gp, G_TXVJUSTIFY) + Memi[gt+GT_TXFONT] = gstati (gp, G_TXFONT) + Memi[gt+GT_TXQUALITY] = gstati (gp, G_TXQUALITY) + Memi[gt+GT_TXCOLOR] = gstati (gp, G_TXCOLOR) + + Memi[gt+GT_DRAWTITLE] = gstati (gp, G_DRAWTITLE) + Memr[P2R(gt+GT_TITLESIZE)] = gstatr (gp, G_TITLESIZE) + #Memi[gt+GT_TITLEJUST] = gstati (gp, G_TITLEJUST) + Memi[gt+GT_NTITLELINES] = gstati (gp, G_NTITLELINES) + Memr[P2R(gt+GT_ASPECT)] = gstatr (gp, G_ASPECT) + #Memr[P2R(gt+GT_CHARSIZE)] = gstatr (gp, G_CHARSIZE) + Memi[gt+GT_TITLECOLOR] = gstati (gp, G_TITLECOLOR) + Memi[gt+GT_FRAMECOLOR] = gstati (gp, G_FRAMECOLOR) + + Memi[gt+GT_XDRAWAXES] = gstati (gp, G_XDRAWAXES) + Memi[gt+GT_XSETAXISPOS] = gstati (gp, G_XSETAXISPOS) + Memr[P2R(gt+GT_XAXISPOS1)] = gstatr (gp, G_XAXISPOS1) + Memr[P2R(gt+GT_XAXISPOS2)] = gstatr (gp, G_XAXISPOS2) + Memi[gt+GT_XDRAWGRID] = gstati (gp, G_YDRAWGRID) + Memi[gt+GT_XROUND] = gstati (gp, G_XROUND) + Memi[gt+GT_XLABELAXIS] = gstati (gp, G_XLABELAXIS) + Memr[P2R(gt+GT_XAXISLABELSIZE)] = gstatr (gp, G_XAXISLABELSIZE) + Memi[gt+GT_XDRAWTICKS] = gstati (gp, G_XDRAWTICKS) + Memi[gt+GT_XLABELTICKS] = gstati (gp, G_XLABELTICKS) + Memi[gt+GT_XNMAJOR] = gstati (gp, G_XNMAJOR) + #Memi[gt+GT_XNMINOR] = gstati (gp, G_XNMINOR) + Memi[gt+GT_XNMINOR] = 0 + Memr[P2R(gt+GT_XMAJORLENGTH)] = gstatr (gp, G_XMAJORLENGTH) + Memr[P2R(gt+GT_XMINORLENGTH)] = gstatr (gp, G_XMINORLENGTH) + Memr[P2R(gt+GT_XMAJORWIDTH)] = gstatr (gp, G_XMAJORWIDTH) + Memr[P2R(gt+GT_XMINORWIDTH)] = gstatr (gp, G_XMINORWIDTH) + Memr[P2R(gt+GT_XAXISWIDTH)] = gstatr (gp, G_XAXISWIDTH) + Memr[P2R(gt+GT_XTICKLABELSIZE)] = gstatr (gp, G_XTICKLABELSIZE) + Memi[gt+GT_XGRIDCOLOR] = gstati (gp, G_XGRIDCOLOR) + Memi[gt+GT_XAXISLABELCOLOR] = gstati (gp, G_XAXISLABELCOLOR) + Memi[gt+GT_XAXISCOLOR] = gstati (gp, G_XAXISCOLOR) + Memi[gt+GT_XTICKLABELCOLOR] = gstati (gp, G_XTICKLABELCOLOR) + Memi[gt+GT_XTICKCOLOR] = gstati (gp, G_XTICKCOLOR) + + Memi[gt+GT_YDRAWAXES] = gstati (gp, G_YDRAWAXES) + Memi[gt+GT_YSETAXISPOS] = gstati (gp, G_YSETAXISPOS) + Memr[P2R(gt+GT_YAXISPOS1)] = gstatr (gp, G_YAXISPOS1) + Memr[P2R(gt+GT_YAXISPOS2)] = gstatr (gp, G_YAXISPOS2) + Memi[gt+GT_YDRAWGRID] = gstati (gp, G_XDRAWGRID) + Memi[gt+GT_YROUND] = gstati (gp, G_YROUND) + Memi[gt+GT_YLABELAXIS] = gstati (gp, G_YLABELAXIS) + Memr[P2R(gt+GT_YAXISLABELSIZE)] = gstatr (gp, G_YAXISLABELSIZE) + Memi[gt+GT_YDRAWTICKS] = gstati (gp, G_YDRAWTICKS) + Memi[gt+GT_YLABELTICKS] = gstati (gp, G_YLABELTICKS) + Memi[gt+GT_YNMAJOR] = gstati (gp, G_YNMAJOR) + #Memi[gt+GT_YNMINOR] = gstati (gp, G_YNMINOR) + Memi[gt+GT_YNMINOR] = 0 + Memr[P2R(gt+GT_YMAJORLENGTH)] = gstatr (gp, G_YMAJORLENGTH) + Memr[P2R(gt+GT_YMINORLENGTH)] = gstatr (gp, G_YMINORLENGTH) + Memr[P2R(gt+GT_YMAJORWIDTH)] = gstatr (gp, G_YMAJORWIDTH) + Memr[P2R(gt+GT_YMINORWIDTH)] = gstatr (gp, G_YMINORWIDTH) + Memr[P2R(gt+GT_YAXISWIDTH)] = gstatr (gp, G_YAXISWIDTH) + Memr[P2R(gt+GT_YTICKLABELSIZE)] = gstatr (gp, G_YTICKLABELSIZE) + Memi[gt+GT_YGRIDCOLOR] = gstati (gp, G_YGRIDCOLOR) + Memi[gt+GT_YAXISLABELCOLOR] = gstati (gp, G_YAXISLABELCOLOR) + Memi[gt+GT_YAXISCOLOR] = gstati (gp, G_YAXISCOLOR) + Memi[gt+GT_YTICKLABELCOLOR] = gstati (gp, G_YTICKLABELCOLOR) + Memi[gt+GT_YTICKCOLOR] = gstati (gp, G_YTICKCOLOR) + + GT_RESET(gt) = YES +end diff --git a/pkg/xtools/gtools/gtlabax.x b/pkg/xtools/gtools/gtlabax.x new file mode 100644 index 00000000..28f80367 --- /dev/null +++ b/pkg/xtools/gtools/gtlabax.x @@ -0,0 +1,139 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <gset.h> +include <gio.h> +include "gtools.h" + +# GT_LABAX -- Set graphics axis. + +procedure gt_labax (gp, gt) + +pointer gp # GIO pointer +pointer gt # GTOOLS pointer + +int nl, len +real vx1, vx2, vy1, vy2, wx1, wx2, wy1, wy2 +pointer title, xlabel, ylabel + +int strlen() + +begin + if (gt != NULL) { + call gt_reset (gp, gt) + + call ggview (gp, vx1, vx2, vy1, vy2) + if (!IS_INDEF(GT_VXMIN(gt))) + vx1 = GT_VXMIN(gt) + if (!IS_INDEF(GT_VXMAX(gt))) + vx2 = GT_VXMAX(gt) + if (!IS_INDEF(GT_VYMIN(gt))) + vy1 = GT_VYMIN(gt) + if (!IS_INDEF(GT_VYMAX(gt))) + vy2 = GT_VYMAX(gt) + call gsview (gp, vx1, vx2, vy1, vy2) + + call malloc (title, SZ_LINE, TY_CHAR) + len = SZ_LINE + Memc[title] = EOS + if (GT_DRWTITLE(gt) == YES) { + nl = NO + if (GT_SYSID(gt) == YES) { + call sysid (Memc[title], len) + len = len + strlen (Memc[title]) + 1 + call realloc (title, len, TY_CHAR) + nl = YES + } + if (GT_PARAMS(gt) != NULL) { + len = len + strlen (Memc[GT_PARAMS(gt)]) + 1 + call realloc (title, len, TY_CHAR) + if (nl == YES) + call strcat ("\n", Memc[title], len) + call strcat (Memc[GT_PARAMS(gt)], Memc[title], len) + nl = YES + } + if (GT_TITLE(gt) != NULL) { + len = len + strlen (Memc[GT_TITLE(gt)]) + 1 + call realloc (title, len, TY_CHAR) + if (nl == YES) + call strcat ("\n", Memc[title], len) + call strcat (Memc[GT_TITLE(gt)], Memc[title], len) + nl = YES + } + if (GT_SUBTITLE(gt) != NULL) { + len = len + strlen (Memc[GT_SUBTITLE(gt)]) + 1 + call realloc (title, len, TY_CHAR) + if (nl == YES) + call strcat ("\n", Memc[title], len) + call strcat (Memc[GT_SUBTITLE(gt)], Memc[title], len) + nl = YES + } + if (GT_COMMENTS(gt) != NULL) { + len = len + strlen (Memc[GT_COMMENTS(gt)]) + 1 + call realloc (title, len, TY_CHAR) + if (nl == YES) + call strcat ("\n", Memc[title], len) + call strcat (Memc[GT_COMMENTS(gt)], Memc[title], len) + nl = YES + } + } + + call malloc (xlabel, SZ_LINE, TY_CHAR) + Memc[xlabel] = EOS + if (GT_DRWXLABELS(gt) == YES) { + if (GT_XLABEL(gt) != NULL) + call strcat (Memc[GT_XLABEL(gt)], Memc[xlabel], SZ_LINE) + if (GT_XUNITS(gt) != NULL) { + call strcat (" (", Memc[xlabel], SZ_LINE) + call strcat (Memc[GT_XUNITS(gt)], Memc[xlabel], SZ_LINE) + call strcat (")", Memc[xlabel], SZ_LINE) + } + } + if (GT_XFORMAT(gt) != NULL) + call gsets (gp, G_XTICKFORMAT, Memc[GT_XFORMAT(gt)]) + + call malloc (ylabel, SZ_LINE, TY_CHAR) + Memc[ylabel] = EOS + if (GT_DRWYLABELS(gt) == YES) { + if (GT_YLABEL(gt) != NULL) + call strcat (Memc[GT_YLABEL(gt)], Memc[ylabel], SZ_LINE) + if (GT_YUNITS(gt) != NULL) { + call strcat (" (", Memc[ylabel], SZ_LINE) + call strcat (Memc[GT_YUNITS(gt)], Memc[ylabel], SZ_LINE) + call strcat (")", Memc[ylabel], SZ_LINE) + } + } + if (GT_YFORMAT(gt) != NULL) + call gsets (gp, G_YTICKFORMAT, Memc[GT_YFORMAT(gt)]) + + call gseti (gp, G_XNMINOR, Memi[gt+GT_XNMINOR]) + call gseti (gp, G_YNMINOR, Memi[gt+GT_YNMINOR]) + if (GT_TRANSPOSE(gt) == NO) + call glabax (gp, Memc[title], Memc[xlabel], Memc[ylabel]) + else + call glabax (gp, Memc[title], Memc[ylabel], Memc[xlabel]) + + call ggview (gp, vx1, vx2, vy1, vy2) + call ggwind (gp, wx1, wx2, wy1, wy2) + call sprintf (Memc[title], SZ_LINE, "%g %g %g %g %g %g %g %g") + call pargr (vx1) + call pargr (vx2) + call pargr (vy1) + call pargr (vy2) + call pargr (wx1) + call pargr (wx2) + call pargr (wy1) + call pargr (wy2) + if (GP_UIFNAME(gp) != EOS) + call gmsg (gp, "gtwcs", Memc[title]) + + call mfree (title, TY_CHAR) + call mfree (xlabel, TY_CHAR) + call mfree (ylabel, TY_CHAR) + } else { + call gmftitle (gp, "UNTITLED") + call gseti (gp, G_XNMINOR, Memi[gt+GT_XNMINOR]) + call gseti (gp, G_YNMINOR, Memi[gt+GT_YNMINOR]) + call glabax (gp, "", "", "") + } +end diff --git a/pkg/xtools/gtools/gtools.h b/pkg/xtools/gtools/gtools.h new file mode 100644 index 00000000..672510b5 --- /dev/null +++ b/pkg/xtools/gtools/gtools.h @@ -0,0 +1,168 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Public Definitions + +define GTVXMIN 0 # Viewport X minimum +define GTVXMAX 1 # Viewport X maximum +define GTVYMIN 2 # Viewport Y minimum +define GTVYMAX 3 # Viewport Y maximum +define GTXMIN 4 # WCS X minimum +define GTXMAX 5 # WCS X maximum +define GTYMIN 6 # WCS Y minimum +define GTYMAX 7 # WCS Y maximum + +define GTSYSID 8 # Add SYSID? +define GTPARAMS 9 # Graph parameters +define GTTITLE 10 # Graph title +define GTSUBTITLE 11 # Graph subtitle +define GTCOMMENTS 12 # Comments +define GTXLABEL 13 # X label +define GTYLABEL 14 # Y label +define GTXUNITS 15 # X units +define GTYUNITS 16 # Y units + +define GTDRAWTITLE 17 # Draw title block? +define GTDRAWXLABELS 18 # Draw x axis label block? +define GTDRAWYLABELS 19 # Draw y axis label block? + +define GTTYPE 20 # Graph type +define GTMARK 21 # Mark type +define GTLINE 22 # Line type +define GTXSIZE 23 # X Mark size +define GTYSIZE 24 # Y Mark size +define GTCOLOR 25 # Color + +define GTXTRAN 26 # WCS X transform +define GTYTRAN 27 # WCS Y transform +define GTXFLIP 28 # Flip X axis +define GTYFLIP 29 # Flip Y axis +define GTTRANSPOSE 30 # Transpose X and Y axes? + +define GTXFORMAT 31 # X format +define GTYFORMAT 32 # Y format + +define GTXBUF 33 # Autoscaling buffer factor +define GTYBUF 34 # Autoscaling buffer factor +define GTLCLIP 35 # Low clipping factor +define GTHCLIP 36 # High clipping factor + +# Private Definitions + +define GTRESET 37 # Initialized from GIO structure? + +define GT_TXUP 51 # Text parameters +define GT_TXSIZE 52 +define GT_TXPATH 53 +define GT_TXSPACING 54 +define GT_TXHJUSTIFY 55 +define GT_TXVJUSTIFY 56 +define GT_TXFONT 57 +define GT_TXQUALITY 58 +define GT_TXCOLOR 59 + +define GT_DRAWTITLE 60 # GLABAX, general parameters +define GT_TITLESIZE 61 +define GT_TITLEJUST 62 +define GT_NTITLELINES 63 +define GT_ASPECT 64 +define GT_CHARSIZE 65 +define GT_TITLECOLOR 66 +define GT_FRAMECOLOR 67 +define GT_DRIDCOLOR 68 + +define GT_XDRAWAXES 71 # GLABAX, x axis parameters +define GT_XSETAXISPOS 72 +define GT_XAXISPOS1 73 +define GT_XAXISPOS2 74 +define GT_XDRAWGRID 75 +define GT_XROUND 76 +define GT_XLABELAXIS 77 +define GT_XAXISLABELSIZE 78 +define GT_XDRAWTICKS 79 +define GT_XLABELTICKS 80 +define GT_XNMAJOR 81 +define GT_XNMINOR 82 +define GT_XMAJORLENGTH 83 +define GT_XMINORLENGTH 84 +define GT_XMAJORWIDTH 85 +define GT_XMINORWIDTH 86 +define GT_XAXISWIDTH 87 +define GT_XTICKLABELSIZE 88 +define GT_XTICKFORMAT 89 +define GT_XGRIDCOLOR 90 +define GT_XAXISLABELCOLOR 91 +define GT_XAXISCOLOR 92 +define GT_XTICKLABELCOLOR 93 +define GT_XTICKCOLOR 94 + +define GT_YDRAWAXES 101 # GLABAX, y axis parameters +define GT_YSETAXISPOS 102 +define GT_YAXISPOS1 103 +define GT_YAXISPOS2 104 +define GT_YDRAWGRID 105 +define GT_YROUND 106 +define GT_YLABELAXIS 107 +define GT_YAXISLABELSIZE 108 +define GT_YDRAWTICKS 109 +define GT_YLABELTICKS 110 +define GT_YNMAJOR 111 +define GT_YNMINOR 112 +define GT_YMAJORLENGTH 113 +define GT_YMINORLENGTH 114 +define GT_YMAJORWIDTH 115 +define GT_YMINORWIDTH 116 +define GT_YAXISWIDTH 117 +define GT_YTICKLABELSIZE 118 +define GT_YTICKFORMAT 119 +define GT_YGRIDCOLOR 120 +define GT_YAXISLABELCOLOR 121 +define GT_YAXISCOLOR 122 +define GT_YTICKLABELCOLOR 123 +define GT_YTICKCOLOR 124 + +define LEN_GT 125 # Length of graphics tools extension + +define GT_VXMIN Memr[P2R($1+GTVXMIN)] +define GT_VXMAX Memr[P2R($1+GTVXMAX)] +define GT_VYMIN Memr[P2R($1+GTVYMIN)] +define GT_VYMAX Memr[P2R($1+GTVYMAX)] +define GT_XMIN Memr[P2R($1+GTXMIN)] +define GT_XMAX Memr[P2R($1+GTXMAX)] +define GT_YMIN Memr[P2R($1+GTYMIN)] +define GT_YMAX Memr[P2R($1+GTYMAX)] +define GT_SYSID Memi[$1+GTSYSID] +define GT_PARAMS Memi[$1+GTPARAMS] +define GT_TITLE Memi[$1+GTTITLE] +define GT_SUBTITLE Memi[$1+GTSUBTITLE] +define GT_COMMENTS Memi[$1+GTCOMMENTS] +define GT_XLABEL Memi[$1+GTXLABEL] +define GT_YLABEL Memi[$1+GTYLABEL] +define GT_XUNITS Memi[$1+GTXUNITS] +define GT_YUNITS Memi[$1+GTYUNITS] +define GT_DRWTITLE Memi[$1+GTDRAWTITLE] +define GT_DRWXLABELS Memi[$1+GTDRAWXLABELS] +define GT_DRWYLABELS Memi[$1+GTDRAWYLABELS] +define GT_TYPE Memi[$1+GTTYPE] +define GT_MARK Memi[$1+GTMARK] +define GT_LINE Memi[$1+GTLINE] +define GT_XSIZE Memr[P2R($1+GTXSIZE)] +define GT_YSIZE Memr[P2R($1+GTYSIZE)] +define GT_COLOR Memi[$1+GTCOLOR] +define GT_XTRAN Memi[$1+GTXTRAN] +define GT_YTRAN Memi[$1+GTYTRAN] +define GT_XFLIP Memi[$1+GTXFLIP] +define GT_YFLIP Memi[$1+GTYFLIP] +define GT_TRANSPOSE Memi[$1+GTTRANSPOSE] +define GT_XFORMAT Memi[$1+GTXFORMAT] +define GT_YFORMAT Memi[$1+GTYFORMAT] +define GT_XBUF Memr[P2R($1+GTXBUF)] +define GT_YBUF Memr[P2R($1+GTYBUF)] +define GT_LCLIP Memr[P2R($1+GTLCLIP)] +define GT_HCLIP Memr[P2R($1+GTHCLIP)] +define GT_RESET Memi[$1+GTRESET] + +define GTTYPES "|mark|line|histogram|" +define GTMARKS "|point|box|plus|cross|diamond|hline|vline|hebar|vebar|circle|" + +define GT_XAXES "|none|bottom|top|both|" +define GT_YAXES "|none|left|right|both|" diff --git a/pkg/xtools/gtools/gtools.hd b/pkg/xtools/gtools/gtools.hd new file mode 100644 index 00000000..bc88b47b --- /dev/null +++ b/pkg/xtools/gtools/gtools.hd @@ -0,0 +1,3 @@ +# Help directory for the GTOOLS (graphics tools) package. + +revisions sys = Revisions diff --git a/pkg/xtools/gtools/gtools.hlp b/pkg/xtools/gtools/gtools.hlp new file mode 100644 index 00000000..43d5e3ab --- /dev/null +++ b/pkg/xtools/gtools/gtools.hlp @@ -0,0 +1,91 @@ +.help gtools Apr96 xtools.gtools +.ih +NAME +gtools -- Graphics tools +.ih +SYNOPSIS +A number of application tasks use the graphics tools in the \fBgtools\fR +package. The graphics tools control labeling and titling of graphs and +interactive formatting. The user changes the defaults via colon commands +and with cursor keys. The windowing options are usually entered with the +'w' key from an application program but other keys may be used instead. +Not all of the formatting options may be available in a particular +application; for example the graph type and mark type options. Check the +documentation for the application program. Some applications set the +values every time the graph is redraw so any user changes will be +overridden. + +The title block consists of a system identification banner, a parameter +string, a title string, a subtitle string, and a comment string in +that order. The \fIdrawtitle\fR parameter can be used to turn off all +the title block. There are parameters to control each of the +parts of the title block. The \fIsubtitle\fR and \fIcomments\fR +parameters are rarely used by applications and so may be used to +annotate graphs. The x and y labels consist of label and units strings. +The \fIdrawxlabels\fR and \fIdrawylabels\fR parameters can be used to +turn off both parts of the axis labels. +.ih +WINDOW COMMANDS +The following keystroke cursor commands may be available in an application. + +.nf +a Autoscale x and y axes +b Set bottom edge of window +c Center window at cursor position +d Shift window down +e Expand window (mark lower left and upper right of new window) +f Flip x axis +g Flip y axis +j Set left edge of window +k Set right edge of window +l Shift window left +m Autoscale x axis +n Autoscale y axis +p Pan x and y axes about cursor +r Shift window right +t Set top edge of window +u Shift window up +x Zoom x axis about cursor +y Zoom y axis about cursor +z Zoom x and y axes about cursor +.fi +.ih +COLON COMMANDS +.nf +:/help Print help menu +:/redraw Redraw the graph + +:/drawtitle [yes|no] Draw title block? +:/sysid [yes|no] Include the standard IRAF user/date banner? +:/parameters string Parameter string (usual set by application) +:/title string Title +:/subtitle string Subtitle +:/comments string Comments + +:/type string Type of graph (line, hist, or mark) +:/mark string Mark type (point, box, plus, cross, diamond, + hline, vline, hebar, vebar, circle) +:/line [0-9] Line style +:/color [0-9] Line or mark color + +:/drawxlabels [yes|no] Draw X axis label? +:/xlabel string Label for X axis +:/xunits string Units for X axis +:/xsize size Size of marks along the X axis +:/xtransform type X coordinate transform type (linear or logarithmic) +:/xwindow x1 x2 X graph window (INDEF defaults to min or max) +:/xflip [yes|no] Flip X axis + +:/drawylabels [yes|no] Draw Y axis label? +:/ylabel string Label for Y axis +:/yunits string Units for Y axis +:/ysize size Size of marks along the Y axis +:/ytransform type Y coordinate transform type (linear or logarithmic) +:/ywindow y1 y2 Y graph window (INDEF defaults to min or max) +:/yflip [yes|no] Flip Y axis + +:/transpose Transpose the graph axes + +Format changes do not take effect until the graph is redrawn. +.fi +.endhelp diff --git a/pkg/xtools/gtools/gtplot.x b/pkg/xtools/gtools/gtplot.x new file mode 100644 index 00000000..3591e6ab --- /dev/null +++ b/pkg/xtools/gtools/gtplot.x @@ -0,0 +1,82 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include "gtools.h" + +# GT_GRAPH -- Plot polymarks or polypoints. + +procedure gt_plot (gp, gt, x, y, npts) + +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +real x[npts] # Abscissas +real y[npts] # Ordinates +int npts # Number of points + +int i, color, pltype, gstati() +real x1, x2 + +begin + switch (GT_TYPE(gt)) { + case 1: + #color = gstati (gp, G_PMCOLOR) + #call gseti (gp, G_PMCOLOR, GT_COLOR(gt)) + color = gstati (gp, G_PLCOLOR) + call gseti (gp, G_PLCOLOR, GT_COLOR(gt)) + if (GT_TRANSPOSE(gt) == NO) + call gpmark (gp, x, y, npts, GT_MARK(gt), GT_XSIZE(gt), + GT_YSIZE(gt)) + else + call gpmark (gp, y, x, npts, GT_MARK(gt), GT_YSIZE(gt), + GT_XSIZE(gt)) + #call gseti (gp, G_PMCOLOR, color) + call gseti (gp, G_PLCOLOR, color) + case 2: + color = gstati (gp, G_PLCOLOR) + call gseti (gp, G_PLCOLOR, GT_COLOR(gt)) + pltype = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, GT_LINE(gt)) + if (GT_TRANSPOSE(gt) == NO) + call gpline (gp, x, y, npts) + else + call gpline (gp, y, x, npts) + call gseti (gp, G_PLTYPE, pltype) + call gseti (gp, G_PLCOLOR, color) + case 3: + color = gstati (gp, G_PLCOLOR) + call gseti (gp, G_PLCOLOR, GT_COLOR(gt)) + pltype = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, GT_LINE(gt)) + if (GT_TRANSPOSE(gt) == NO) { + x1 = x[1] + x2 = (x[1] + x[2]) / 2 + call gline (gp, x1, y[1], x2, y[1]) + do i = 2, npts - 1 { + x1 = x2 + x2 = (x[i] + x[i+1]) / 2 + call gline (gp, x1, y[i-1], x1, y[i]) + call gline (gp, x1, y[i], x2 , y[i]) + } + x1 = x2 + x2 = x[npts] + call gline (gp, x1, y[i-1], x1, y[i]) + call gline (gp, x1, y[i], x2 , y[i]) + } else { + x1 = y[1] + x2 = (y[1] + y[2]) / 2 + call gline (gp, x1, x[1], x2, x[1]) + do i = 2, npts - 1 { + x1 = x2 + x2 = (y[i] + y[i+1]) / 2 + call gline (gp, x1, x[i-1], x1, x[i]) + call gline (gp, x1, x[i], x2 , x[i]) + } + x1 = x2 + x2 = y[npts] + call gline (gp, x1, y[i-1], x1, y[i]) + call gline (gp, x1, y[i], x2 , y[i]) + } + call gseti (gp, G_PLTYPE, pltype) + call gseti (gp, G_PLCOLOR, color) + } +end diff --git a/pkg/xtools/gtools/gtreset.x b/pkg/xtools/gtools/gtreset.x new file mode 100644 index 00000000..696db0cd --- /dev/null +++ b/pkg/xtools/gtools/gtreset.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include "gtools.h" + +# GT_RESET -- Reset parameters after a gclear, greset, or gcancel. + +procedure gt_reset (gp, gt) + +pointer gp #I GIO pointer +pointer gt #I GTOOLS pointer + +begin + if (GT_RESET(gt) == NO) + call gt_ireset (gp, gt) + + call gseti (gp, G_TXUP, Memi[gt+GT_TXUP]) + call gsetr (gp, G_TXSIZE, Memr[P2R(gt+GT_TXSIZE)]) + call gseti (gp, G_TXPATH, Memi[gt+GT_TXPATH]) + call gsetr (gp, G_TXSPACING, Memr[P2R(gt+GT_TXSPACING)]) + call gseti (gp, G_TXHJUSTIFY, Memi[gt+GT_TXHJUSTIFY]) + call gseti (gp, G_TXVJUSTIFY, Memi[gt+GT_TXVJUSTIFY]) + call gseti (gp, G_TXFONT, Memi[gt+GT_TXFONT]) + call gseti (gp, G_TXQUALITY, Memi[gt+GT_TXQUALITY]) + call gseti (gp, G_TXCOLOR, Memi[gt+GT_TXCOLOR]) + + call gseti (gp, G_DRAWTITLE, Memi[gt+GT_DRAWTITLE]) + call gsetr (gp, G_TITLESIZE, Memr[P2R(gt+GT_TITLESIZE)]) + #call gseti (gp, G_TITLEJUST, Memi[gt+GT_TITLEJUST]) + call gseti (gp, G_NTITLELINES, Memi[gt+GT_NTITLELINES]) + call gsetr (gp, G_ASPECT, Memr[P2R(gt+GT_ASPECT)]) + #call gsetr (gp, G_CHARSIZE, Memr[P2R(gt+GT_CHARSIZE)]) + call gseti (gp, G_TITLECOLOR, Memi[gt+GT_TITLECOLOR]) + call gseti (gp, G_FRAMECOLOR, Memi[gt+GT_FRAMECOLOR]) + + call gseti (gp, G_XDRAWAXES, Memi[gt+GT_XDRAWAXES]) + call gseti (gp, G_XSETAXISPOS, Memi[gt+GT_XSETAXISPOS]) + call gsetr (gp, G_XAXISPOS1, Memr[P2R(gt+GT_XAXISPOS1)]) + call gsetr (gp, G_XAXISPOS2, Memr[P2R(gt+GT_XAXISPOS2)]) + call gseti (gp, G_YDRAWGRID, Memi[gt+GT_XDRAWGRID]) + call gseti (gp, G_XROUND, Memi[gt+GT_XROUND]) + call gseti (gp, G_XLABELAXIS, Memi[gt+GT_XLABELAXIS]) + call gsetr (gp, G_XAXISLABELSIZE, Memr[P2R(gt+GT_XAXISLABELSIZE)]) + call gseti (gp, G_XDRAWTICKS, Memi[gt+GT_XDRAWTICKS]) + call gseti (gp, G_XLABELTICKS, Memi[gt+GT_XLABELTICKS]) + call gseti (gp, G_XNMAJOR, Memi[gt+GT_XNMAJOR]) + call gseti (gp, G_XNMINOR, Memi[gt+GT_XNMINOR]) + call gsetr (gp, G_XMAJORLENGTH, Memr[P2R(gt+GT_XMAJORLENGTH)]) + call gsetr (gp, G_XMINORLENGTH, Memr[P2R(gt+GT_XMINORLENGTH)]) + call gsetr (gp, G_XMAJORWIDTH, Memr[P2R(gt+GT_XMAJORWIDTH)]) + call gsetr (gp, G_XMINORWIDTH, Memr[P2R(gt+GT_XMINORWIDTH)]) + call gsetr (gp, G_XAXISWIDTH, Memr[P2R(gt+GT_XAXISWIDTH)]) + call gsetr (gp, G_XTICKLABELSIZE, Memr[P2R(gt+GT_XTICKLABELSIZE)]) + call gseti (gp, G_XGRIDCOLOR, Memi[gt+GT_XGRIDCOLOR]) + call gseti (gp, G_XAXISLABELCOLOR, Memi[gt+GT_XAXISLABELCOLOR]) + call gseti (gp, G_XAXISCOLOR, Memi[gt+GT_XAXISCOLOR]) + call gseti (gp, G_XTICKLABELCOLOR, Memi[gt+GT_XTICKLABELCOLOR]) + call gseti (gp, G_XTICKCOLOR, Memi[gt+GT_XTICKCOLOR]) + + call gseti (gp, G_YDRAWAXES, Memi[gt+GT_YDRAWAXES]) + call gseti (gp, G_YSETAXISPOS, Memi[gt+GT_YSETAXISPOS]) + call gsetr (gp, G_YAXISPOS1, Memr[P2R(gt+GT_YAXISPOS1)]) + call gsetr (gp, G_YAXISPOS2, Memr[P2R(gt+GT_YAXISPOS2)]) + call gseti (gp, G_XDRAWGRID, Memi[gt+GT_YDRAWGRID]) + call gseti (gp, G_YROUND, Memi[gt+GT_YROUND]) + call gseti (gp, G_YLABELAXIS, Memi[gt+GT_YLABELAXIS]) + call gsetr (gp, G_YAXISLABELSIZE, Memr[P2R(gt+GT_YAXISLABELSIZE)]) + call gseti (gp, G_YDRAWTICKS, Memi[gt+GT_YDRAWTICKS]) + call gseti (gp, G_YLABELTICKS, Memi[gt+GT_YLABELTICKS]) + call gseti (gp, G_YNMAJOR, Memi[gt+GT_YNMAJOR]) + call gseti (gp, G_YNMINOR, Memi[gt+GT_YNMINOR]) + call gsetr (gp, G_YMAJORLENGTH, Memr[P2R(gt+GT_YMAJORLENGTH)]) + call gsetr (gp, G_YMINORLENGTH, Memr[P2R(gt+GT_YMINORLENGTH)]) + call gsetr (gp, G_YMAJORWIDTH, Memr[P2R(gt+GT_YMAJORWIDTH)]) + call gsetr (gp, G_YMINORWIDTH, Memr[P2R(gt+GT_YMINORWIDTH)]) + call gsetr (gp, G_YAXISWIDTH, Memr[P2R(gt+GT_YAXISWIDTH)]) + call gsetr (gp, G_YTICKLABELSIZE, Memr[P2R(gt+GT_YTICKLABELSIZE)]) + call gseti (gp, G_YGRIDCOLOR, Memi[gt+GT_YGRIDCOLOR]) + call gseti (gp, G_YAXISLABELCOLOR, Memi[gt+GT_YAXISLABELCOLOR]) + call gseti (gp, G_YAXISCOLOR, Memi[gt+GT_YAXISCOLOR]) + call gseti (gp, G_YTICKLABELCOLOR, Memi[gt+GT_YTICKLABELCOLOR]) + call gseti (gp, G_YTICKCOLOR, Memi[gt+GT_YTICKCOLOR]) +end diff --git a/pkg/xtools/gtools/gtset.x b/pkg/xtools/gtools/gtset.x new file mode 100644 index 00000000..d5eb33cb --- /dev/null +++ b/pkg/xtools/gtools/gtset.x @@ -0,0 +1,224 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <gset.h> +include "gtools.h" + +# GT_SETI -- Set integer parameters. + +procedure gt_seti (gt, param, ival) + +pointer gt # GTOOLS pointer +int param # Parameter to set +int ival # Integer value to set + +begin + if (gt == NULL) + return + + switch (param) { + case GTLINE: + GT_LINE(gt) = ival + case GTTRANSPOSE: + GT_TRANSPOSE(gt) = ival + case GTSYSID: + GT_SYSID(gt) = ival + case GTCOLOR: + GT_COLOR(gt) = ival + case GTXFLIP: + GT_XFLIP(gt) = ival + case GTYFLIP: + GT_YFLIP(gt) = ival + case GTDRAWTITLE: + GT_DRWTITLE(gt) = ival + case GTDRAWXLABELS: + GT_DRWXLABELS(gt) = ival + case GTDRAWYLABELS: + GT_DRWYLABELS(gt) = ival + } +end + + +# GT_SETR -- Set real parameters. + +procedure gt_setr (gt, param, rval) + +pointer gt # GTOOLS pointer +int param # Parameter to set +real rval # Real value to set + +begin + if (gt == NULL) + return + + switch (param) { + case GTVXMIN: + GT_VXMIN(gt) = rval + case GTVXMAX: + GT_VXMAX(gt) = rval + case GTVYMIN: + GT_VYMIN(gt) = rval + case GTVYMAX: + GT_VYMAX(gt) = rval + case GTXMIN: + if (GT_XFLIP(gt) == NO) + GT_XMIN(gt) = rval + else + GT_XMAX(gt) = rval + case GTXMAX: + if (GT_XFLIP(gt) == NO) + GT_XMAX(gt) = rval + else + GT_XMIN(gt) = rval + case GTYMIN: + if (GT_YFLIP(gt) == NO) + GT_YMIN(gt) = rval + else + GT_YMAX(gt) = rval + case GTYMAX: + if (GT_YFLIP(gt) == NO) + GT_YMAX(gt) = rval + else + GT_YMIN(gt) = rval + case GTXBUF: + GT_XBUF(gt) = rval + case GTYBUF: + GT_YBUF(gt) = rval + case GTLCLIP: + GT_LCLIP(gt) = rval + case GTHCLIP: + GT_HCLIP(gt) = rval + case GTXSIZE: + GT_XSIZE(gt) = rval + case GTYSIZE: + GT_YSIZE(gt) = rval + } +end + + +# GT_SETS -- Set string parameters. + +procedure gt_sets (gt, param, str) + +pointer gt # GTOOLS pointer +int param # Parameter to set +char str[ARB] # String + +char dummy[10] +int len + +int marks[10] +data marks /GM_POINT,GM_BOX,GM_PLUS,GM_CROSS,GM_DIAMOND,GM_HLINE,GM_VLINE, + GM_HEBAR,GM_VEBAR,GM_CIRCLE/ +int trans[2] +data trans /GW_LINEAR, GW_ELOG/ + +int strlen(), strdic() + +begin + if (gt == NULL) + return + + len = strlen (str) + switch (param) { + case GTPARAMS: + call mfree (GT_PARAMS(gt), TY_CHAR) + if (len > 0) { + call malloc (GT_PARAMS(gt), len, TY_CHAR) + call strcpy (str, Memc[GT_PARAMS(gt)], len) + } + case GTTITLE: + call mfree (GT_TITLE(gt), TY_CHAR) + if (len > 0) { + call malloc (GT_TITLE(gt), len, TY_CHAR) + call strcpy (str, Memc[GT_TITLE(gt)], len) + } + case GTSUBTITLE: + call mfree (GT_SUBTITLE(gt), TY_CHAR) + if (len > 0) { + call malloc (GT_SUBTITLE(gt), len, TY_CHAR) + call strcpy (str, Memc[GT_SUBTITLE(gt)], len) + } + case GTCOMMENTS: + call mfree (GT_COMMENTS(gt), TY_CHAR) + if (len > 0) { + call malloc (GT_COMMENTS(gt), len, TY_CHAR) + call strcpy (str, Memc[GT_COMMENTS(gt)], len) + } + case GTXLABEL: + call mfree (GT_XLABEL(gt), TY_CHAR) + if (len > 0) { + call malloc (GT_XLABEL(gt), len, TY_CHAR) + call strcpy (str, Memc[GT_XLABEL(gt)], len) + } + case GTYLABEL: + call mfree (GT_YLABEL(gt), TY_CHAR) + if (len > 0) { + call malloc (GT_YLABEL(gt), len, TY_CHAR) + call strcpy (str, Memc[GT_YLABEL(gt)], len) + } + case GTXUNITS: + call mfree (GT_XUNITS(gt), TY_CHAR) + if (len > 0) { + call malloc (GT_XUNITS(gt), len, TY_CHAR) + call strcpy (str, Memc[GT_XUNITS(gt)], len) + } + case GTYUNITS: + call mfree (GT_YUNITS(gt), TY_CHAR) + if (len > 0) { + call malloc (GT_YUNITS(gt), len, TY_CHAR) + call strcpy (str, Memc[GT_YUNITS(gt)], len) + } + case GTXFORMAT: + call mfree (GT_XFORMAT(gt), TY_CHAR) + if (len > 0) { + call malloc (GT_XFORMAT(gt), len, TY_CHAR) + call strcpy (str, Memc[GT_XFORMAT(gt)], len) + } + case GTYFORMAT: + call mfree (GT_YFORMAT(gt), TY_CHAR) + if (len > 0) { + call malloc (GT_YFORMAT(gt), len, TY_CHAR) + call strcpy (str, Memc[GT_YFORMAT(gt)], len) + } + case GTXTRAN: + len = strdic (str, dummy, 10, "|linear|logarithmic|") + if (len == 0) { + call eprintf ("Unknown X transformation type `%s'\n") + call pargstr (str) + } else + GT_XTRAN(gt) = trans[len] + case GTYTRAN: + len = strdic (str, dummy, 10, "|linear|logarithmic|") + if (len == 0) { + call eprintf ("Unknown Y transformation type `%s'\n") + call pargstr (str) + } else + GT_YTRAN(gt) = trans[len] + case GTTYPE: + len = strdic (str, dummy, 10, GTMARKS) + if (len > 0) { + GT_TYPE(gt) = 1 + GT_MARK(gt) = marks[len] + return + } + call strcpy (str, dummy, 10) + if (IS_DIGIT(str[5])) { + GT_LINE(gt) = TO_INTEG(str[5]) + dummy[5] = EOS + } + len = strdic (dummy, dummy, 10, GTTYPES) + if (len == 0) { + call eprintf ("Unknown graph type `%s'\n") + call pargstr (str) + } else + GT_TYPE(gt) = len + case GTMARK: + len = strdic (str, dummy, 10, GTMARKS) + if (len == 0) { + call eprintf ("Unknown mark type `%s'\n") + call pargstr (str) + } else + GT_MARK(gt) = marks[len] + } +end diff --git a/pkg/xtools/gtools/gtswind.x b/pkg/xtools/gtools/gtswind.x new file mode 100644 index 00000000..02766326 --- /dev/null +++ b/pkg/xtools/gtools/gtswind.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <mach.h> +include "gtools.h" + +# GT_SWIND -- Set graphics window. + +procedure gt_swind (gp, gt) + +pointer gp # GIO pointer +pointer gt # GTOOLS pointer + +real xmin, xmax, dx, ymin, ymax, dy + +begin + if (gt != NULL) { + if (GT_TRANSPOSE(gt) == NO) { + call gseti (gp, G_XTRAN, GT_XTRAN(gt)) + call gseti (gp, G_YTRAN, GT_YTRAN(gt)) + } else { + call gseti (gp, G_YTRAN, GT_XTRAN(gt)) + call gseti (gp, G_XTRAN, GT_YTRAN(gt)) + } + call ggwind (gp, xmin, xmax, ymin, ymax) + dx = xmax - xmin + dy = ymax - ymin + + if (IS_INDEF (GT_XMIN(gt))) + xmin = xmin - GT_XBUF(gt) * dx + else + xmin = GT_XMIN(gt) + + if (IS_INDEF (GT_XMAX(gt))) + xmax = xmax + GT_XBUF(gt) * dx + else + xmax = GT_XMAX(gt) + + if (IS_INDEF (GT_YMIN(gt))) + ymin = ymin - GT_YBUF(gt) * dy + else + ymin = GT_YMIN(gt) + + if (IS_INDEF (GT_YMAX(gt))) + ymax = ymax + GT_YBUF(gt) * dy + else + ymax = GT_YMAX(gt) + + if (GT_XFLIP(gt) == YES) { + dx = xmin + xmin = xmax + xmax = dx + } + if (GT_YFLIP(gt) == YES) { + dy = ymin + ymin = ymax + ymax = dy + } + + if (GT_TRANSPOSE(gt) == NO) + call gswind (gp, xmin, xmax, ymin, ymax) + else + call gswind (gp, ymin, ymax, xmin, xmax) + } +end diff --git a/pkg/xtools/gtools/gtvplot.x b/pkg/xtools/gtools/gtvplot.x new file mode 100644 index 00000000..23550c3d --- /dev/null +++ b/pkg/xtools/gtools/gtvplot.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include "gtools.h" + +# GT_VPLOT -- Plot vector polymarks or polylines. + +procedure gt_vplot (gp, gt, v, npts, x1, x2) + +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +real v[npts] # Abscissas +int npts # Number of points +real x1, x2 # Vector range + +int i, pltype, color, gstati() +real x, dx + +begin + switch (GT_TYPE(gt)) { + case 1: + color = gstati (gp, G_PMCOLOR) + call gseti (gp, G_PMCOLOR, GT_COLOR(gt)) + call gvmark (gp, v, npts, x1, x2, GT_MARK(gt), GT_XSIZE(gt), + GT_YSIZE(gt)) + call gseti (gp, G_PMCOLOR, color) + case 2: + color = gstati (gp, G_PLCOLOR) + call gseti (gp, G_PLCOLOR, GT_COLOR(gt)) + pltype = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, GT_LINE(gt)) + call gvline (gp, v, npts, x1, x2) + call gseti (gp, G_PLTYPE, pltype) + call gseti (gp, G_PLCOLOR, color) + case 3: + color = gstati (gp, G_PLCOLOR) + call gseti (gp, G_PLCOLOR, GT_COLOR(gt)) + pltype = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, GT_LINE(gt)) + dx = (x2 - x1) / (npts - 1) + x = x1 - dx / 2 + do i = 1, npts-1 { + x = x + dx + call gline (gp, x-dx, v[i], x, v[i]) + call gline (gp, x, v[i], x, v[i+1]) + } + call gline (gp, x, v[npts], x+dx, v[npts]) + call gseti (gp, G_PLTYPE, pltype) + call gseti (gp, G_PLCOLOR, color) + } +end diff --git a/pkg/xtools/gtools/gtwindow.x b/pkg/xtools/gtools/gtwindow.x new file mode 100644 index 00000000..4a150d74 --- /dev/null +++ b/pkg/xtools/gtools/gtwindow.x @@ -0,0 +1,180 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gtools.h" + +define HELP "lib$scr/gtwindow.key" +define PROMPT "window options" + +# GT_WINDOW -- Set graph window with the cursor. + +procedure gt_window (gt, gp, cursor, redraw) + +pointer gt # GTOOLS pointer +pointer gp # GIO pointer +char cursor[ARB] # Cursor +int redraw # Redraw flag + +char cmd[1] +int wcs1, key1, wcs2, key2, clgcur() +real wx1, wy1, wx2, wy2 + +begin + call printf ( "window:") + if (clgcur (cursor, wx1, wy1, wcs1, key1, cmd, SZ_LINE) == EOF) + return + switch (key1) { + case 'e': + call printf ("again:") + if (clgcur (cursor, wx2, wy2, wcs2, key2, cmd, SZ_LINE) == EOF) + return + call gt_window2 (gt, gp, wx1, wy1, wcs1, key1, cmd, + wx2, wy2, wcs2, key2, cmd, redraw) + default: + call gt_window1 (gt, gp, wx1, wy1, wcs1, key1, cmd, redraw) + } + call printf ("") +end + + +# GT_WINDOW1 -- Act on window command. + +procedure gt_window1 (gt, gp, wx, wy, wcs, key, cmd, redraw) + +pointer gt #I GTOOLS pointer +pointer gp #I GIO pointer +real wx #I X Coordinate +real wy #I Y Coordinate +int wcs #I WCS +int key #I Key +char cmd[ARB] #I Command +int redraw #O Redraw flag + +int gt_geti() +real x1, x2, y1, y2, dx, dy, wx1, wy1 + +begin + redraw = YES + call ggwind (gp, x1, x2, y1, y2) + dx = x2 - x1 + dy = y2 - y1 + + wx1 = wx + wy1 = wy + if (IS_INDEF(wx1)) + wx1 = (x1 + x2) / 2. + if (IS_INDEF(wy1)) + wy1 = (y1 + y2) / 2. + + + switch (key) { + case '?': # Print help text + call gpagefile (gp, HELP, PROMPT) + redraw = NO + case 'a': # Autoscale x and y axes + call gt_setr (gt, GTXMIN, INDEF) + call gt_setr (gt, GTXMAX, INDEF) + call gt_setr (gt, GTYMIN, INDEF) + call gt_setr (gt, GTYMAX, INDEF) + case 'b': # Bottom edge + call gt_setr (gt, GTYMIN, wy1) + case 'c': + call gt_setr (gt, GTXMIN, wx1 - dx / 2) + call gt_setr (gt, GTXMAX, wx1 + dx / 2) + call gt_setr (gt, GTYMIN, wy1 - dy / 2) + call gt_setr (gt, GTYMAX, wy1 + dy / 2) + case 'd': # Shift down + call gt_setr (gt, GTYMIN, y1 - 0.75 * dy) + call gt_setr (gt, GTYMAX, y2 - 0.75 * dy) + case 'f': # Flip x axis + if (gt_geti (gt, GTXFLIP) == NO) + call gt_seti (gt, GTXFLIP, YES) + else + call gt_seti (gt, GTXFLIP, NO) + case 'g': # Flip y axis + if (gt_geti (gt, GTYFLIP) == NO) + call gt_seti (gt, GTYFLIP, YES) + else + call gt_seti (gt, GTYFLIP, NO) + case 'j': # Left edge + call gt_setr (gt, GTXMIN, wx1) + case 'k': # Right edge + call gt_setr (gt, GTXMAX, wx1) + case 'l': # Shift left + call gt_setr (gt, GTXMIN, x1 - 0.75 * dx) + call gt_setr (gt, GTXMAX, x2 - 0.75 * dx) + case 'm': # Autoscale x axis + call gt_setr (gt, GTXMIN, INDEF) + call gt_setr (gt, GTXMAX, INDEF) + case 'n': # Autoscale y axis + call gt_setr (gt, GTYMIN, INDEF) + call gt_setr (gt, GTYMAX, INDEF) + case 'p': # Pan + call gt_setr (gt, GTXMIN, wx1 - dx) + call gt_setr (gt, GTXMAX, wx1 + dx) + call gt_setr (gt, GTYMIN, wy1 - dy) + call gt_setr (gt, GTYMAX, wy1 + dy) + case 'r': # Shift right + call gt_setr (gt, GTXMIN, x1 + 0.75 * dx) + call gt_setr (gt, GTXMAX, x2 + 0.75 * dx) + case 't': # Top edge + call gt_setr (gt, GTYMAX, wy1) + case 'u': # Shift up + call gt_setr (gt, GTYMIN, y1 + 0.75 * dy) + call gt_setr (gt, GTYMAX, y2 + 0.75 * dy) + case 'x': # Zoom x axis + call gt_setr (gt, GTXMIN, wx1 - dx / 4) + call gt_setr (gt, GTXMAX, wx1 + dx / 4) + case 'y': # Zoom y axis + call gt_setr (gt, GTYMIN, wy1 - dy / 4) + call gt_setr (gt, GTYMAX, wy1 + dy / 4) + case 'z': # Zoom x and y axis + call gt_setr (gt, GTXMIN, wx1 - dx / 4) + call gt_setr (gt, GTXMAX, wx1 + dx / 4) + call gt_setr (gt, GTYMIN, wy1 - dy / 4) + call gt_setr (gt, GTYMAX, wy1 + dy / 4) + case 'I': + call fatal (0, "Interrupt") + default: + call printf ("\07") + redraw = NO + } +end + + +# GT_WINDOW2 -- Act on window command. + +procedure gt_window2 (gt, gp, wx1, wy1, wcs1, key1, cmd1, + wx2, wy2, wcs2, key2, cmd2, redraw) + +pointer gt #I GTOOLS pointer +pointer gp #I GIO pointer +real wx1, wx2 #I X Coordinate +real wy1, wy2 #I Y Coordinate +int wcs1, wcs2 #I WCS +int key1, key2 #I Key +char cmd1[ARB], cmd2[ARB] #I Command +int redraw #O Redraw flag + +real x1, x2, y1, y2, dx, dy + +begin + redraw = YES + call ggwind (gp, x1, x2, y1, y2) + dx = x2 - x1 + dy = y2 - y1 + + switch (key1) { + case 'e': # Expand window + if (abs (wx2 - wx1) > 0.001 * abs (dx)) { + call gt_setr (gt, GTXMIN, wx1) + call gt_setr (gt, GTXMAX, wx2) + } + if (abs (wy2 - wy1) > 0.001 * abs (dy)) { + call gt_setr (gt, GTYMIN, wy1) + call gt_setr (gt, GTYMAX, wy2) + } + default: + call printf ("\07\n") + redraw = NO + } +end diff --git a/pkg/xtools/gtools/mkpkg b/pkg/xtools/gtools/mkpkg new file mode 100644 index 00000000..bbad01aa --- /dev/null +++ b/pkg/xtools/gtools/mkpkg @@ -0,0 +1,27 @@ +# GTOOLS + +update: + $checkout libxtools.a lib$ + $update libxtools.a + $checkin libxtools.a lib$ + ; + +libxtools.a: + gtascale.x gtools.h <mach.h> + gtcolon.x gtools.h <ctype.h> <gset.h> + gtcopy.x gtools.h + gtctran.x + gtcur.x + gtcur1.x gtools.h + gtfree.x gtools.h + gtget.x gtools.h <gset.h> + gtgui.x gtools.h <gset.h> + gtinit.x gtools.h <gset.h> + gtlabax.x gtools.h <ctype.h> <gset.h> <gio.h> + gtplot.x gtools.h <gset.h> + gtreset.x gtools.h <gset.h> + gtset.x gtools.h <ctype.h> <gset.h> + gtswind.x gtools.h <gset.h> <mach.h> + gtvplot.x gtools.h <gset.h> + gtwindow.x gtools.h + ; diff --git a/pkg/xtools/icfit/Revisions b/pkg/xtools/icfit/Revisions new file mode 100644 index 00000000..0117042e --- /dev/null +++ b/pkg/xtools/icfit/Revisions @@ -0,0 +1,405 @@ +.help revisions Jun88 pkg.xtools.icfit +.nf +icdeviant.gx + There were two bugs related to growing. First, the logic was wrong. + Second, in one place the grow parameter was treated as being in pixels + and in another as being in user coordinate units. + (6/28/10, Valdes) + +icdosetup.gx + When there is only one sample range that is binned to a single point + this would result in the fitting limits (introduced 8/11/00) being + equal. This causes cvinit to return an error and the cv pointer + is invald. The change is if the number of binned fitting points + is 1 then the full range of the unbinned data is used. Note that + a change was also made on this date to have cvinit return a null + pointer rather than a partially initialized pointer. (11/18/02, Valdes) + +======= +V2.12.1 +======= + +===== +V2.12 +===== + +icdosetup.gx + The change made previously is now restricted to the polynomial functions + which make sense to extrapolate. The spline functions define the + fitting region to be the region set by the calling program. + (11/21/00, Valdes) + +icfshow.gx + Will now work if the GT pointer is NULL. (8/19/00, Valdes) + +icdosetup.gx + When using sample ranges the fitting region is now limited to the + minimum and maximum of the fitted region. (8/11/00, Valdes) + +========= +V2.11.3p1 +========= +======= +V2.11.3 +======= + +icgui.x + Eliminated gmsg calls when there is no GUI. (2/1/99, Valdes) + +icshow.x +icvshow.gx + The gt pointer was not being used when called by CURFIT noninteractively. + The IC_GT structure is now set in these routines. (9/14/99, Valdes) + +======= +V2.11.2 +======= + +icggraph.gx + Moved smark to after an initial return. (7/11/99, Valdes) + +icgfit.x + This routine is called with a graphics descriptor for interactive + fitting. The descriptor is set in an internal structure. Other + procedures, which may be called both for interactive and + non-interactive fitting, check if the descriptor is not NULL + before sending GUI messages. The problem occurs if this procedure is + first called interactively and then the non-interactive fitting + routine is called later (maybe after a deactivate workstation or + closing the descriptor) resulting in GUI messages being sent + when not in interactive mode. The solution is to return the + internal descriptor value to NULL after finishing the interactive + fitting and returning from this procedure. (7/22/99, Valdes) + +icgui.x + Fixed bug in behavior when there is no gui. (4/2/99, Valdes) + +icfit.h +names.h +icgfit.gx +icparams.x +icggraph.gx +icgcolon.gx +icgui.x +icferrors.gx +icshow.x +icerrors.gx +icvshow.gx +icguishow.gx +icfvshow.gx +mkpkg + Added support for GUIs. (12/7/98, Valdes) + +======= +V2.11.1 +======= + +======= +V2.11.0 +======= + +pkg$xtools/icfit/icfit.hlp + Changed the order of the task name and version number in the revisions + section. (4/22/97, Valdes) + +pkg$xtools/icgcolon.gx +pkg$xtools/icfit/icfit.hlp + Changed the "fitvalue" colon command to "evaluate" to avoid abbreviation + conflict with "function". (4/16/97, Valdes) + +pkg$xtools/icfit/icshow.x + The commenting of the title string needed to be modified since the + title string could include new lines and we want each line to be + commented. (3/27/97, Valdes) + +pkg$xtools/icfit/icgcolon.gx +pkg$xtools/icfit/icfit.hlp + Added a "fitvalue" colon command to evaluate the fit at an arbitrary value. + (1/28/97, Valdes) + +pkg$xtools/icfit/icvshow.gx +pkg$xtools/icfit/icshow.x +pkg$xtools/icfit/icerrors.gx + All output except the tabular part of :xyshow now begins with + the comment character. Comment column labels were added back. + (2/29/96, Valdes) + +pkg$xtools/icfit/icvshow.gx +pkg$xtools/icfit/icgcolon.gx +pkg$xtools/icfit/icfit.help + Enhanced the :xyshow command to include the weights and not print + column labels. (11/20/95, Valdes) + +pkg$xtools/icfit/icparams.x + Added an ic_geti paramter "nmin" to return the minimum number of + points that can be fit. (9/8/95, Valdes) + +pkg$xtools/icfit/icgfit.h + The prototype capability of adding points was supposed to return to + the calling program as if only the original data was used however + the structure element giving the number of points fit was the number + after adding the points. This causes other routines to think the + data was sampled in some way which then leads to attempting to + reference a NULL array. The routine now sets the number of points + fit back to the input value upon completion. (7/12/95, Valdes) + +pkg$xtools/icfit/icfit.h +pkg$xtools/icfit/icparams.x +pkg$xtools/icfit/icggraph.gx +pkg$xtools/icfit/icgcolon.gx +pkg$xtools/icfit/icfit.hlp + Added a color option for the fit. Users may set it with :color and + applications with ic_puti. (6/30/95, Valdes) + +======= +V2.10.4 +======= + +pkg$xtools/icfit/icdosetup.gx + Fixed two type mismatches in min/max calls. (12/30/94, Valdes) + +pkg$xtools/icfit/icgfit.gx +pkg$xtools/icfit/icfit.hlp + Added 'v' key to change fitting weight. (12/29/94, Valdes) + +pkg$xtools/icparams.gx + Make it legal to call ic_closed with a null pointer. (8/11/93, Valdes) + +============ +V2.10.3 beta +============ + +pkg$xtools/icfit.gx + This procedure now sets the IC_FITERROR structure element so that + a program using only the noninteractive ic_fit will have this element + defined. The procedure will still return with an error condition + if an error occurs as was true previously. (6/29/93, Valdes) + +pkg$xtools/icdosetup.gx + The fitting min and max given to cvinit is now calculated from the data + avoiding errors in setting it by calling programs. This was especially + dangerous because fitting data outside this range can cause memory + corruption errors by the CURFIT routines. (7/29/92, Valdes) + +======= +V2.10.1 +======= + +pkg$xtools/icfit/icgcolon.gx +pkg$xtools/icfit/icggraph.gx +pkg$xtools/icfit/icparams.x +pkg$xtools/icfit/icfit.h +pkg$xtools/icfit/icfit.hlp +noao$lib/src/icgfit.key +noao$lib/src/idicgfit.key + Added a new user parameter called "markrej" to toggle whether to mark + rejected points or not. (1/21/92, Valdes) + +pkg$xtools/icfit/icfit.hlp +pkg$xtools/icfit/icgsample.gx +pkg$xtools/icfit/icgfit.gx +pkg$xtools/icfit/icgcolon.gx +pkg$xtools/icfit/icparams.x +pkg$xtools/icfit/icfit.h +pkg$xtools/icfit/icfit.hlp + 1. Added 'z' key to delete individual sample regions. + 2. Increased the internal sample string to 1024 characters. + (9/4/91, Valdes) + +pkg$xtools/icfit/icfit.hlp +pkg$xtools/icfit/icgfit.gx +pkg$xtools/icfit/icgadd.gx +pkg$xtools/icfit/ mkpkg + Added 'a' key to allow adding points for constraining the fit. + (9/3/91, Valdes) + +pkg$xtools/icfit/icfit.hlp + Fixed typo for :errors description. (11/20/90, Valdes) + +pkg$xtools/icfit/icgcolon.gx + 1. Unrecognized or ambiguous colon commands are now noted. + (10/2/90, Valdes) + +pkg$xtools/icfit/icvshow.gx +pkg$xtools/icfit/icgcolon.gx +pkg$xtools/icfit/icfit.hlp +noaolib$scr/icgfit.key + 1. The :vshow command now does not print the (x, y fit, y) values. + 2. A new user command, :xyshow, prints the (x, y fit, y) values. + (5/16/90, Valdes) + +==== +V2.9 +==== + +pkg$xtools/icfit/icparams.x +pkg$xtools/icfit/icgcolon.x + 1. ic_puti uses max (1, order) for setting the order. + 2. icg_colon prints error if attempting to set order < 1. + (3/6/90, Valdes) + +pkg$xtools/icfit/icparams.x + Added ability to get information about the number of fit points and the + rejected points to the ic_geti procedure. (5/4/89, Valdes) + +pkg$xtools/icfit/icggraph.gx + Scaled the symbol used for marking average points to the appropriate + coordinate system. This is still only approximately correct. + Based on a report by Ivo Busko. (3/1/89, Valdes) + +pkg$xtools/icfit/icvshow.gx + + Changed output format of 3 values so 7 digits of precision are printed. + This was in response to a user request for the utilities.curfit task, + but all programs calling icvshow will be affected. (ShJ 3-NOV-88) + +< call fprintf (fd, "RMS = %10.7g\n") +> call fprintf (fd, "RMS = %7.4g\n") + +< call fprintf (fd, "square root of reduced chi square = %10.7g\n") +> call fprintf (fd, "square root of reduced chi square = %7.4g\n") + +< call fprintf (fd, "\t%14.7e\t%14.7e\n") +> call fprintf (fd, "\t%10.4e\t%10.4e\n") + +pkg$xtools/icfit/icgfit.gx +pkg$xtools/icfit/icgaddfit.gx +noao$lib/scr/icgfit.key + Added 'I' interrupt key. (4/20/88 Valdes) + +pkg$xtools/icfit/icgfit.gx +pkg$xtools/icfit/icgparams.gx + Valdes, Jan. 5, 1988 + Added checks for an error in fitting the curve. + +pkg$xtools/icfit/icgfit.gx + Valdes, Oct. 2, 1987 + 1. When doing sample regions there was a round off problem with + negative numbers. Replaced int(x+.5) with nint(x). + +pkg$xtools/icfit/icfit.h +pkg$xtools/icfit/icparams.x +pkg$xtools/icfit/icguaxes.gx + Valdes, February 20,1987 + 1. Made the cursor help file a setable parameter since the graph + keys are definable by the application. + 2. Added the radial velocity axis type explicitly to the package + to remove the need for onedspec.identify to have it's own copy + of the package. + +pkg$xtools/icfit/*x + Valdes, February 17, 1987 + 1. Required GIO changes. + +pkg$xtools/icfit/icgcolon.gx + Valdes, January 16, 1987 + 1. Colon command dictionary and switch modified to use macro definitions. + +pkg$xtools/icfit/icgfit.gx +noao$lib/scr/icgfit.key +noao$lib/scr/icgaxes.key - + Valdes, January 13, 1987 + 1. When setting sample ranges with the cursor the range limits are now + rounded to the nearest integer only if the x values are integers. + Previously it always rounded even if the data were not integers. + 2. Modified to use system page procedure for printing help. + 3. Revised the help file and included the graph axes help in the same + file since it is now paged. The separate axes help file was deleted. + +pkg$xtools/icfit/icgcolon.gx + Valdes, October 7, 1986 + 1. It is no longer possible to set naverage to 0 which causes ICFIT + to crash. A message is now printed telling the user that 0 is + not a legal value. This error is present in V2.3 and earlier. + +pkg$xtools/icfit/icgdelete.gx +pkg$xtools/icfit/icgundelete.gx + Valdes, September 8, 1986 + 1. Procedures were defined as function but used as subroutines. The + function declarations were removed. Found during the Alliant port. + +pkg$xtools/icfit/icgfit.gx +noao$onedspec/identify/icfit/icgfit.gx + Valdes, August 21, 1986 + 1. When defining sample ranges interactively with the cursor the + new sample string was appended to the previous string without + a leading space and with a trailing space. This was fine if + the sample was defined only interactively or only explicitly + as a string. However, appending an interactive sample to one + the user types in (without a trailing blank) is an error. + Changed the interactive appending to put a leading blank and + no trailing blank. + +noao$lib/src/icgfit.key + Valdes, August 20, 1986 + 1. The key file listed :lowreject and :highreject instead of the + correct :low_reject and :high_reject. The key file was fixed. + +==================================== +Version 2.3 Release, August 18, 1986 +==================================== + +icfit$: Valdes, August 11, 1986 + 1. Reorganized package to have separate objects for each procedure. + This allows loading only the procedures of the desired datatype. + +icfit$icgfit.gx: Valdes, August 7, 1986 + 1. The 'c' key was using a fixed format inappropriate for some types + of data. The formats where changed to general %g format. + +icfit$icgfit.gx: Valdes, August 7, 1986 + 1. A bug in the generic code was causing a double to be + passed to gt_setr which caused the windowing to be wrong. + This bug appeared only in the SUN. + 2. A bug in writing the current key definition with the 'g' key was + fixed. This bug appeared only in the SUN. + +icfit: Valdes, July 3, 1986 + 1. New ICFIT package. + +icfit$icggraph.gx: Valdes, April 28, 1986 + 1. Fixed bug in icggraph.gx: + real $tcveval ---> PIXEL $tcveval + +icfit$icgfit.gx,icgfit2.x,icgcolon.x: Valdes, April 7, 1986 + 1. Fixed use of STRIDX with a character constant to STRIDXS. + 2. Fixed problem with colon usage for ":sample" and ":function" + +icfit: Valdes, Mar 13, 1986: + 1. ICFIT package converted to generic form. The package now has entries + for both single precision and double precision data. It uses the new + curfit math library which now has double precision entries as well. + The external names of the single precision procedures are unchanged. +====== +Release 2.2 +====== +From Valdes Dec 30 , 1985 + +1. Setting of sample ranges by cursor was integer truncating giving the +funny result that if the cursor was set at 4.99 the sample limit was 4. +This has been changed so that the sample limit is rounded to the nearest +integer. +------ +From Valdes Nov 20 , 1985 + +1. New procedure ICG_FIT2 added. This procedure does all graphics +open and closes and has cl parameters "graphics", "plots", and "cursor". +This will eventually phase out ICG_FIT. + +2. Procedures modified to use an array of GTOOLS pointers instead of +keeping them in separate variables. This allows easy expansion to add +additional graph formats. +------ +From Valdes Oct 17 , 1985 + +1. Graphing the zero line was removed from icggraph.x because the line +interfered with fitting data near zero. +------ +From Valdes Oct 4, 1985 + +1. The package was modified to add high and low rejection and to iterate +the rejection algorithm. + +2. Procedure icg_params was add to label the graphs with the fitting +parameters. +.endhelp diff --git a/pkg/xtools/icfit/icclean.gx b/pkg/xtools/icfit/icclean.gx new file mode 100644 index 00000000..0d5dd08a --- /dev/null +++ b/pkg/xtools/icfit/icclean.gx @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> +include "icfit.h" +include "names.h" + +# IC_CLEAN -- Replace rejected points by the fitted values. + +procedure ic_clean$t (ic, cv, x, y, w, npts) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +PIXEL x[npts] # Ordinates +PIXEL y[npts] # Abscissas +PIXEL w[npts] # Weights +int npts # Number of points + +int i, nclean, newreject +pointer sp, xclean, yclean, wclean + +PIXEL $tcveval() + +begin + if ((IC_LOW(ic) == 0.) && (IC_HIGH(ic) == 0.)) + return + + # If there has been no subsampling and no sample averaging then the + # IC_REJPTS(ic) array already contains the rejected points. + + if (npts == IC_NFIT(ic)) { + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + y[i] = $tcveval (cv, x[i]) + } + } + + # If there has been no sample averaging then the rejpts array already + # contains indices into the subsampled array. + + } else if (abs(IC_NAVERAGE(ic)) < 2) { + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Mem$t[IC_YFIT(ic)+i-1] = + $tcveval (cv, Mem$t[IC_XFIT(ic)+i-1]) + } + } + call rg_unpack$t (IC_RG(ic), Mem$t[IC_YFIT(ic)], y) + + # Because ic_fit rejects points from the fitting data which + # has been sample averaged the rejpts array refers to the wrong data. + # Do the cleaning using ic_deviant to find the points to reject. + + } else if (RG_NPTS(IC_RG(ic)) == npts) { + call amovki (NO, Memi[IC_REJPTS(ic)], npts) + call ic_deviant$t (cv, x, y, w, Memi[IC_REJPTS(ic)], npts, + IC_LOW(ic), IC_HIGH(ic), IC_GROW(ic), NO, IC_NREJECT(ic), + newreject) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + y[i] = $tcveval (cv, x[i]) + } + } + + # If there is subsampling then allocate temporary arrays for the + # subsample points. + + } else { + call smark (sp) + nclean = RG_NPTS(IC_RG(ic)) + call salloc (xclean, nclean, TY_PIXEL) + call salloc (yclean, nclean, TY_PIXEL) + call salloc (wclean, nclean, TY_PIXEL) + call rg_pack$t (IC_RG(ic), x, Mem$t[xclean]) + call rg_pack$t (IC_RG(ic), y, Mem$t[yclean]) + call rg_pack$t (IC_RG(ic), w, Mem$t[wclean]) + call amovki (NO, Memi[IC_REJPTS(ic)], npts) + call ic_deviant$t (cv, Mem$t[xclean], Mem$t[yclean], + Mem$t[wclean], Memi[IC_REJPTS(ic)], nclean, IC_LOW(ic), + IC_HIGH(ic), IC_GROW(ic), NO, IC_NREJECT(ic), newreject) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Mem$t[yclean+i-1] = $tcveval (cv, Mem$t[xclean+i-1]) + } + } + call rg_unpack$t (IC_RG(ic), Mem$t[yclean], y) + call sfree (sp) + } +end diff --git a/pkg/xtools/icfit/iccleand.x b/pkg/xtools/icfit/iccleand.x new file mode 100644 index 00000000..97c88a19 --- /dev/null +++ b/pkg/xtools/icfit/iccleand.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> +include "icfit.h" +include "names.h" + +# IC_CLEAN -- Replace rejected points by the fitted values. + +procedure ic_cleand (ic, cv, x, y, w, npts) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +double x[npts] # Ordinates +double y[npts] # Abscissas +double w[npts] # Weights +int npts # Number of points + +int i, nclean, newreject +pointer sp, xclean, yclean, wclean + +double dcveval() + +begin + if ((IC_LOW(ic) == 0.) && (IC_HIGH(ic) == 0.)) + return + + # If there has been no subsampling and no sample averaging then the + # IC_REJPTS(ic) array already contains the rejected points. + + if (npts == IC_NFIT(ic)) { + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + y[i] = dcveval (cv, x[i]) + } + } + + # If there has been no sample averaging then the rejpts array already + # contains indices into the subsampled array. + + } else if (abs(IC_NAVERAGE(ic)) < 2) { + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memd[IC_YFIT(ic)+i-1] = + dcveval (cv, Memd[IC_XFIT(ic)+i-1]) + } + } + call rg_unpackd (IC_RG(ic), Memd[IC_YFIT(ic)], y) + + # Because ic_fit rejects points from the fitting data which + # has been sample averaged the rejpts array refers to the wrong data. + # Do the cleaning using ic_deviant to find the points to reject. + + } else if (RG_NPTS(IC_RG(ic)) == npts) { + call amovki (NO, Memi[IC_REJPTS(ic)], npts) + call ic_deviantd (cv, x, y, w, Memi[IC_REJPTS(ic)], npts, + IC_LOW(ic), IC_HIGH(ic), IC_GROW(ic), NO, IC_NREJECT(ic), + newreject) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + y[i] = dcveval (cv, x[i]) + } + } + + # If there is subsampling then allocate temporary arrays for the + # subsample points. + + } else { + call smark (sp) + nclean = RG_NPTS(IC_RG(ic)) + call salloc (xclean, nclean, TY_DOUBLE) + call salloc (yclean, nclean, TY_DOUBLE) + call salloc (wclean, nclean, TY_DOUBLE) + call rg_packd (IC_RG(ic), x, Memd[xclean]) + call rg_packd (IC_RG(ic), y, Memd[yclean]) + call rg_packd (IC_RG(ic), w, Memd[wclean]) + call amovki (NO, Memi[IC_REJPTS(ic)], npts) + call ic_deviantd (cv, Memd[xclean], Memd[yclean], + Memd[wclean], Memi[IC_REJPTS(ic)], nclean, IC_LOW(ic), + IC_HIGH(ic), IC_GROW(ic), NO, IC_NREJECT(ic), newreject) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memd[yclean+i-1] = dcveval (cv, Memd[xclean+i-1]) + } + } + call rg_unpackd (IC_RG(ic), Memd[yclean], y) + call sfree (sp) + } +end diff --git a/pkg/xtools/icfit/iccleanr.x b/pkg/xtools/icfit/iccleanr.x new file mode 100644 index 00000000..cbcff319 --- /dev/null +++ b/pkg/xtools/icfit/iccleanr.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> +include "icfit.h" +include "names.h" + +# IC_CLEAN -- Replace rejected points by the fitted values. + +procedure ic_cleanr (ic, cv, x, y, w, npts) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +real x[npts] # Ordinates +real y[npts] # Abscissas +real w[npts] # Weights +int npts # Number of points + +int i, nclean, newreject +pointer sp, xclean, yclean, wclean + +real rcveval() + +begin + if ((IC_LOW(ic) == 0.) && (IC_HIGH(ic) == 0.)) + return + + # If there has been no subsampling and no sample averaging then the + # IC_REJPTS(ic) array already contains the rejected points. + + if (npts == IC_NFIT(ic)) { + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + y[i] = rcveval (cv, x[i]) + } + } + + # If there has been no sample averaging then the rejpts array already + # contains indices into the subsampled array. + + } else if (abs(IC_NAVERAGE(ic)) < 2) { + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memr[IC_YFIT(ic)+i-1] = + rcveval (cv, Memr[IC_XFIT(ic)+i-1]) + } + } + call rg_unpackr (IC_RG(ic), Memr[IC_YFIT(ic)], y) + + # Because ic_fit rejects points from the fitting data which + # has been sample averaged the rejpts array refers to the wrong data. + # Do the cleaning using ic_deviant to find the points to reject. + + } else if (RG_NPTS(IC_RG(ic)) == npts) { + call amovki (NO, Memi[IC_REJPTS(ic)], npts) + call ic_deviantr (cv, x, y, w, Memi[IC_REJPTS(ic)], npts, + IC_LOW(ic), IC_HIGH(ic), IC_GROW(ic), NO, IC_NREJECT(ic), + newreject) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + y[i] = rcveval (cv, x[i]) + } + } + + # If there is subsampling then allocate temporary arrays for the + # subsample points. + + } else { + call smark (sp) + nclean = RG_NPTS(IC_RG(ic)) + call salloc (xclean, nclean, TY_REAL) + call salloc (yclean, nclean, TY_REAL) + call salloc (wclean, nclean, TY_REAL) + call rg_packr (IC_RG(ic), x, Memr[xclean]) + call rg_packr (IC_RG(ic), y, Memr[yclean]) + call rg_packr (IC_RG(ic), w, Memr[wclean]) + call amovki (NO, Memi[IC_REJPTS(ic)], npts) + call ic_deviantr (cv, Memr[xclean], Memr[yclean], + Memr[wclean], Memi[IC_REJPTS(ic)], nclean, IC_LOW(ic), + IC_HIGH(ic), IC_GROW(ic), NO, IC_NREJECT(ic), newreject) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memr[yclean+i-1] = rcveval (cv, Memr[xclean+i-1]) + } + } + call rg_unpackr (IC_RG(ic), Memr[yclean], y) + call sfree (sp) + } +end diff --git a/pkg/xtools/icfit/icdeviant.gx b/pkg/xtools/icfit/icdeviant.gx new file mode 100644 index 00000000..e4e2cff3 --- /dev/null +++ b/pkg/xtools/icfit/icdeviant.gx @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/curfit.h> +include "names.h" + +# IC_DEVIANT -- Find deviant points with large residuals from the fit +# and reject from the fit. +# +# The sigma of the fit residuals is calculated. The rejection thresholds +# are set at +-reject*sigma. Points outside the rejection threshold are +# recorded in the reject array. + +procedure ic_deviant$t (cv, x, y, w, rejpts, npts, low_reject, high_reject, + grow, refit, nreject, newreject) + +pointer cv # Curve descriptor +PIXEL x[npts] # Input ordinates +PIXEL y[npts] # Input data values +PIXEL w[npts] # Weights +int rejpts[npts] # Points rejected +int npts # Number of input points +real low_reject, high_reject # Rejection thresholds +real grow # Rejection radius +int refit # Refit the curve? +int nreject # Number of points rejected +int newreject # Number of new points rejected + +int i, j, i_min, i_max, pixgrow +PIXEL sigma, low_cut, high_cut, residual +pointer sp, residuals + +begin + # If low_reject and high_reject are zero then simply return. + + if ((low_reject == 0.) && (high_reject == 0.)) + return + + # Allocate memory for the residuals. + + call smark (sp) + call salloc (residuals, npts, TY_PIXEL) + + # Compute the residuals. + + call $tcvvector (cv, x, Mem$t[residuals], npts) + call asub$t (y, Mem$t[residuals], Mem$t[residuals], npts) + + # Compute the sigma of the residuals. If there are less than + # 5 points return. + + j = 0 + nreject = 0 + sigma = 0. + + do i = 1, npts { + if ((w[i] != 0.) && (rejpts[i] == NO)) { + sigma = sigma + Mem$t[residuals+i-1] ** 2 + j = j + 1 + } else if (rejpts[i] == YES) + nreject = nreject + 1 + } + + if (j < 5) { + call sfree (sp) + return + } else + sigma = sqrt (sigma / j) + + if (low_reject > 0.) + low_cut = -low_reject * sigma + else + low_cut = -MAX_REAL + if (high_reject > 0.) + high_cut = high_reject * sigma + else + high_cut = MAX_REAL + + # Reject the residuals exceeding the rejection limits. + # A for loop is used instead of do because with region growing we + # want to modify the loop index. + + pixgrow = 0 + if (grow > 0.) { + do i = 1, npts-1 { + if (abs (x[i+1] - x[i]) < 0.0001) + next + if (i == 1) + pixgrow = grow / abs (x[i+1] - x[i]) + else + pixgrow = max (grow / abs (x[i+1] - x[i]), pixgrow) + } + } + + newreject = 0 + for (i = 1; i <= npts; i = i + 1) { + if (w[i] == 0. || rejpts[i] == YES) + next + + residual = Mem$t[residuals + i - 1] + if (residual < high_cut && residual > low_cut) + next + + i_min = max (1, i - pixgrow) + i_max = min (npts, i + pixgrow) + + # Reject points from the fit and flag them. + do j = i_min, i_max { + if ((abs (x[i] - x[j]) <= grow) && (w[j] != 0.) && + (rejpts[j] == NO)) { + if (refit == YES) + call $tcvrject (cv, x[j], y[j], w[j]) + rejpts[j] = 2 + newreject = newreject + 1 + } + } + } + do i = 1, npts + if (rejpts[i] != NO) + rejpts[i] = YES + + nreject = nreject + newreject + call sfree (sp) + + if ((refit == YES) && (newreject > 0)) { + call $tcvsolve (cv, i) + switch (i) { + case SINGULAR: + call error (1, "ic_reject: Singular solution") + case NO_DEG_FREEDOM: + call error (2, "ic_reject: No degrees of freedom") + } + } +end diff --git a/pkg/xtools/icfit/icdeviantd.x b/pkg/xtools/icfit/icdeviantd.x new file mode 100644 index 00000000..ab16b3d5 --- /dev/null +++ b/pkg/xtools/icfit/icdeviantd.x @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/curfit.h> +include "names.h" + +# IC_DEVIANT -- Find deviant points with large residuals from the fit +# and reject from the fit. +# +# The sigma of the fit residuals is calculated. The rejection thresholds +# are set at +-reject*sigma. Points outside the rejection threshold are +# recorded in the reject array. + +procedure ic_deviantd (cv, x, y, w, rejpts, npts, low_reject, high_reject, + grow, refit, nreject, newreject) + +pointer cv # Curve descriptor +double x[npts] # Input ordinates +double y[npts] # Input data values +double w[npts] # Weights +int rejpts[npts] # Points rejected +int npts # Number of input points +real low_reject, high_reject # Rejection thresholds +real grow # Rejection radius +int refit # Refit the curve? +int nreject # Number of points rejected +int newreject # Number of new points rejected + +int i, j, i_min, i_max, pixgrow +double sigma, low_cut, high_cut, residual +pointer sp, residuals + +begin + # If low_reject and high_reject are zero then simply return. + + if ((low_reject == 0.) && (high_reject == 0.)) + return + + # Allocate memory for the residuals. + + call smark (sp) + call salloc (residuals, npts, TY_DOUBLE) + + # Compute the residuals. + + call dcvvector (cv, x, Memd[residuals], npts) + call asubd (y, Memd[residuals], Memd[residuals], npts) + + # Compute the sigma of the residuals. If there are less than + # 5 points return. + + j = 0 + nreject = 0 + sigma = 0. + + do i = 1, npts { + if ((w[i] != 0.) && (rejpts[i] == NO)) { + sigma = sigma + Memd[residuals+i-1] ** 2 + j = j + 1 + } else if (rejpts[i] == YES) + nreject = nreject + 1 + } + + if (j < 5) { + call sfree (sp) + return + } else + sigma = sqrt (sigma / j) + + if (low_reject > 0.) + low_cut = -low_reject * sigma + else + low_cut = -MAX_REAL + if (high_reject > 0.) + high_cut = high_reject * sigma + else + high_cut = MAX_REAL + + # Reject the residuals exceeding the rejection limits. + # A for loop is used instead of do because with region growing we + # want to modify the loop index. + + pixgrow = 0 + if (grow > 0.) { + do i = 1, npts-1 { + if (abs (x[i+1] - x[i]) < 0.0001) + next + if (i == 1) + pixgrow = grow / abs (x[i+1] - x[i]) + else + pixgrow = max (grow / abs (x[i+1] - x[i]), pixgrow) + } + } + + newreject = 0 + for (i = 1; i <= npts; i = i + 1) { + if (w[i] == 0. || rejpts[i] == YES) + next + + residual = Memd[residuals + i - 1] + if (residual < high_cut && residual > low_cut) + next + + i_min = max (1, i - pixgrow) + i_max = min (npts, i + pixgrow) + + # Reject points from the fit and flag them. + do j = i_min, i_max { + if ((abs (x[i] - x[j]) <= grow) && (w[j] != 0.) && + (rejpts[j] == NO)) { + if (refit == YES) + call dcvrject (cv, x[j], y[j], w[j]) + rejpts[j] = 2 + newreject = newreject + 1 + } + } + } + do i = 1, npts + if (rejpts[i] != NO) + rejpts[i] = YES + + nreject = nreject + newreject + call sfree (sp) + + if ((refit == YES) && (newreject > 0)) { + call dcvsolve (cv, i) + switch (i) { + case SINGULAR: + call error (1, "ic_reject: Singular solution") + case NO_DEG_FREEDOM: + call error (2, "ic_reject: No degrees of freedom") + } + } +end diff --git a/pkg/xtools/icfit/icdeviantr.x b/pkg/xtools/icfit/icdeviantr.x new file mode 100644 index 00000000..5d584377 --- /dev/null +++ b/pkg/xtools/icfit/icdeviantr.x @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/curfit.h> +include "names.h" + +# IC_DEVIANT -- Find deviant points with large residuals from the fit +# and reject from the fit. +# +# The sigma of the fit residuals is calculated. The rejection thresholds +# are set at +-reject*sigma. Points outside the rejection threshold are +# recorded in the reject array. + +procedure ic_deviantr (cv, x, y, w, rejpts, npts, low_reject, high_reject, + grow, refit, nreject, newreject) + +pointer cv # Curve descriptor +real x[npts] # Input ordinates +real y[npts] # Input data values +real w[npts] # Weights +int rejpts[npts] # Points rejected +int npts # Number of input points +real low_reject, high_reject # Rejection thresholds +real grow # Rejection radius +int refit # Refit the curve? +int nreject # Number of points rejected +int newreject # Number of new points rejected + +int i, j, i_min, i_max, pixgrow +real sigma, low_cut, high_cut, residual +pointer sp, residuals + +begin + # If low_reject and high_reject are zero then simply return. + + if ((low_reject == 0.) && (high_reject == 0.)) + return + + # Allocate memory for the residuals. + + call smark (sp) + call salloc (residuals, npts, TY_REAL) + + # Compute the residuals. + + call rcvvector (cv, x, Memr[residuals], npts) + call asubr (y, Memr[residuals], Memr[residuals], npts) + + # Compute the sigma of the residuals. If there are less than + # 5 points return. + + j = 0 + nreject = 0 + sigma = 0. + + do i = 1, npts { + if ((w[i] != 0.) && (rejpts[i] == NO)) { + sigma = sigma + Memr[residuals+i-1] ** 2 + j = j + 1 + } else if (rejpts[i] == YES) + nreject = nreject + 1 + } + + if (j < 5) { + call sfree (sp) + return + } else + sigma = sqrt (sigma / j) + + if (low_reject > 0.) + low_cut = -low_reject * sigma + else + low_cut = -MAX_REAL + if (high_reject > 0.) + high_cut = high_reject * sigma + else + high_cut = MAX_REAL + + # Reject the residuals exceeding the rejection limits. + # A for loop is used instead of do because with region growing we + # want to modify the loop index. + + pixgrow = 0 + if (grow > 0.) { + do i = 1, npts-1 { + if (abs (x[i+1] - x[i]) < 0.0001) + next + if (i == 1) + pixgrow = grow / abs (x[i+1] - x[i]) + else + pixgrow = max (grow / abs (x[i+1] - x[i]), pixgrow) + } + } + + newreject = 0 + for (i = 1; i <= npts; i = i + 1) { + if (w[i] == 0. || rejpts[i] == YES) + next + + residual = Memr[residuals + i - 1] + if (residual < high_cut && residual > low_cut) + next + + i_min = max (1, i - pixgrow) + i_max = min (npts, i + pixgrow) + + # Reject points from the fit and flag them. + do j = i_min, i_max { + if ((abs (x[i] - x[j]) <= grow) && (w[j] != 0.) && + (rejpts[j] == NO)) { + if (refit == YES) + call rcvrject (cv, x[j], y[j], w[j]) + rejpts[j] = 2 + newreject = newreject + 1 + } + } + } + do i = 1, npts + if (rejpts[i] != NO) + rejpts[i] = YES + + nreject = nreject + newreject + call sfree (sp) + + if ((refit == YES) && (newreject > 0)) { + call rcvsolve (cv, i) + switch (i) { + case SINGULAR: + call error (1, "ic_reject: Singular solution") + case NO_DEG_FREEDOM: + call error (2, "ic_reject: No degrees of freedom") + } + } +end diff --git a/pkg/xtools/icfit/icdosetup.gx b/pkg/xtools/icfit/icdosetup.gx new file mode 100644 index 00000000..b4ec4c55 --- /dev/null +++ b/pkg/xtools/icfit/icdosetup.gx @@ -0,0 +1,121 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_DOSETUP -- Setup the fit. This is called at the start of each call +# to ic_fit to update the fitting parameters if necessary. + +procedure ic_dosetup$t (ic, cv, x, wts, npts, newx, newwts, newfunction, refit) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +PIXEL x[npts] # Ordinates of data +PIXEL wts[npts] # Weights +int npts # Number of points in data +int newx # New x points? +int newwts # New weights? +int newfunction # New function? +int refit # Use cvrefit? + +int ord +PIXEL xmin, xmax + +pointer rg_xranges$t() +#extern hd_power$t() +errchk rg_xranges$t + +begin + # Set sample points. + if ((newx == YES) || (newwts == YES)) { + if (npts == 0) + call error (0, "No data points for fit") + + call mfree (IC_XFIT(ic), TY_PIXEL) + call mfree (IC_YFIT(ic), TY_PIXEL) + call malloc (IC_XFIT(ic), npts, TY_PIXEL) + + call mfree (IC_WTSFIT(ic), TY_PIXEL) + call malloc (IC_WTSFIT(ic), npts, TY_PIXEL) + + call mfree (IC_REJPTS(ic), TY_INT) + call malloc (IC_REJPTS(ic), npts, TY_INT) + call amovki (NO, Memi[IC_REJPTS(ic)], npts) + IC_NREJECT(ic) = 0 + + # Set sample points. + + call rg_free (IC_RG(ic)) + IC_RG(ic) = rg_xranges$t (Memc[IC_SAMPLE(ic)], x, npts) + call rg_order (IC_RG(ic)) + call rg_merge (IC_RG(ic)) + call rg_wtbin$t (IC_RG(ic), max (1, abs (IC_NAVERAGE(ic))), x, wts, + npts, Mem$t[IC_XFIT(ic)], Mem$t[IC_WTSFIT(ic)], IC_NFIT(ic)) + + if (IC_NFIT(ic) == 0) + call error (0, "No sample points for fit") + + if (IC_NFIT(ic) == npts) { + call rg_free (IC_RG(ic)) + call mfree (IC_XFIT(ic), TY_PIXEL) + call mfree (IC_WTSFIT(ic), TY_PIXEL) + IC_YFIT(ic) = NULL + IC_WTSFIT(ic) = NULL + call alim$t (x, npts, xmin, xmax) + } else { + call malloc (IC_YFIT(ic), IC_NFIT(ic), TY_PIXEL) + if (IC_NFIT(ic) == 1) + call alim$t (x, npts, xmin, xmax) + else + call alim$t (Mem$t[IC_XFIT(ic)], IC_NFIT(ic), xmin, xmax) + } + + IC_XMIN(ic) = min (IC_XMIN(ic), real(xmin)) + IC_XMAX(ic) = max (IC_XMAX(ic), real(xmax)) + refit = NO + } + + # Set curve fitting parameters. + # For polynomials define fitting range over range of data in fit + # and assume extrpolation is ok. For spline functions define + # fitting range to be range of evaluation set by the caller + # since extrapolation will not make sense. + + if ((newx == YES) || (newfunction == YES)) { + if (cv != NULL) + call $tcvfree (cv) + + switch (IC_FUNCTION(ic)) { + case LEGENDRE, CHEBYSHEV: + ord = min (IC_ORDER(ic), IC_NFIT(ic)) + call $tcvinit (cv, IC_FUNCTION(ic), ord, PIXEL (xmin), + PIXEL (xmax)) + case SPLINE1: + ord = min (IC_ORDER(ic), IC_NFIT(ic) - 1) + if (ord > 0) + call $tcvinit (cv, SPLINE1, ord, PIXEL (IC_XMIN(ic)), + PIXEL (IC_XMAX(ic))) + else + call $tcvinit (cv, LEGENDRE, IC_NFIT(ic), + PIXEL (IC_XMIN(ic)), PIXEL (IC_XMAX(ic))) + case SPLINE3: + ord = min (IC_ORDER(ic), IC_NFIT(ic) - 3) + if (ord > 0) + call $tcvinit (cv, SPLINE3, ord, PIXEL (IC_XMIN(ic)), + PIXEL (IC_XMAX(ic))) + else + call $tcvinit (cv, LEGENDRE, IC_NFIT(ic), + PIXEL (IC_XMIN(ic)), PIXEL (IC_XMAX(ic))) +# case USERFNC: +# ord = min (IC_ORDER(ic), IC_NFIT(ic)) +# call $tcvinit (cv, USERFNC, ord, PIXEL (IC_XMIN(ic)), +# PIXEL (IC_XMAX(ic))) +# call $tcvuserfnc (cv, hd_power$t) + default: + call error (0, "Unknown fitting function") + } + + refit = NO + } +end diff --git a/pkg/xtools/icfit/icdosetupd.x b/pkg/xtools/icfit/icdosetupd.x new file mode 100644 index 00000000..98b64939 --- /dev/null +++ b/pkg/xtools/icfit/icdosetupd.x @@ -0,0 +1,121 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_DOSETUP -- Setup the fit. This is called at the start of each call +# to ic_fit to update the fitting parameters if necessary. + +procedure ic_dosetupd (ic, cv, x, wts, npts, newx, newwts, newfunction, refit) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +double x[npts] # Ordinates of data +double wts[npts] # Weights +int npts # Number of points in data +int newx # New x points? +int newwts # New weights? +int newfunction # New function? +int refit # Use cvrefit? + +int ord +double xmin, xmax + +pointer rg_xrangesd() +#extern hd_power$t() +errchk rg_xrangesd + +begin + # Set sample points. + if ((newx == YES) || (newwts == YES)) { + if (npts == 0) + call error (0, "No data points for fit") + + call mfree (IC_XFIT(ic), TY_DOUBLE) + call mfree (IC_YFIT(ic), TY_DOUBLE) + call malloc (IC_XFIT(ic), npts, TY_DOUBLE) + + call mfree (IC_WTSFIT(ic), TY_DOUBLE) + call malloc (IC_WTSFIT(ic), npts, TY_DOUBLE) + + call mfree (IC_REJPTS(ic), TY_INT) + call malloc (IC_REJPTS(ic), npts, TY_INT) + call amovki (NO, Memi[IC_REJPTS(ic)], npts) + IC_NREJECT(ic) = 0 + + # Set sample points. + + call rg_free (IC_RG(ic)) + IC_RG(ic) = rg_xrangesd (Memc[IC_SAMPLE(ic)], x, npts) + call rg_order (IC_RG(ic)) + call rg_merge (IC_RG(ic)) + call rg_wtbind (IC_RG(ic), max (1, abs (IC_NAVERAGE(ic))), x, wts, + npts, Memd[IC_XFIT(ic)], Memd[IC_WTSFIT(ic)], IC_NFIT(ic)) + + if (IC_NFIT(ic) == 0) + call error (0, "No sample points for fit") + + if (IC_NFIT(ic) == npts) { + call rg_free (IC_RG(ic)) + call mfree (IC_XFIT(ic), TY_DOUBLE) + call mfree (IC_WTSFIT(ic), TY_DOUBLE) + IC_YFIT(ic) = NULL + IC_WTSFIT(ic) = NULL + call alimd (x, npts, xmin, xmax) + } else { + call malloc (IC_YFIT(ic), IC_NFIT(ic), TY_DOUBLE) + if (IC_NFIT(ic) == 1) + call alimd (x, npts, xmin, xmax) + else + call alimd (Memd[IC_XFIT(ic)], IC_NFIT(ic), xmin, xmax) + } + + IC_XMIN(ic) = min (IC_XMIN(ic), real(xmin)) + IC_XMAX(ic) = max (IC_XMAX(ic), real(xmax)) + refit = NO + } + + # Set curve fitting parameters. + # For polynomials define fitting range over range of data in fit + # and assume extrpolation is ok. For spline functions define + # fitting range to be range of evaluation set by the caller + # since extrapolation will not make sense. + + if ((newx == YES) || (newfunction == YES)) { + if (cv != NULL) + call dcvfree (cv) + + switch (IC_FUNCTION(ic)) { + case LEGENDRE, CHEBYSHEV: + ord = min (IC_ORDER(ic), IC_NFIT(ic)) + call dcvinit (cv, IC_FUNCTION(ic), ord, double (xmin), + double (xmax)) + case SPLINE1: + ord = min (IC_ORDER(ic), IC_NFIT(ic) - 1) + if (ord > 0) + call dcvinit (cv, SPLINE1, ord, double (IC_XMIN(ic)), + double (IC_XMAX(ic))) + else + call dcvinit (cv, LEGENDRE, IC_NFIT(ic), + double (IC_XMIN(ic)), double (IC_XMAX(ic))) + case SPLINE3: + ord = min (IC_ORDER(ic), IC_NFIT(ic) - 3) + if (ord > 0) + call dcvinit (cv, SPLINE3, ord, double (IC_XMIN(ic)), + double (IC_XMAX(ic))) + else + call dcvinit (cv, LEGENDRE, IC_NFIT(ic), + double (IC_XMIN(ic)), double (IC_XMAX(ic))) +# case USERFNC: +# ord = min (IC_ORDER(ic), IC_NFIT(ic)) +# call $tcvinit (cv, USERFNC, ord, PIXEL (IC_XMIN(ic)), +# PIXEL (IC_XMAX(ic))) +# call $tcvuserfnc (cv, hd_power$t) + default: + call error (0, "Unknown fitting function") + } + + refit = NO + } +end diff --git a/pkg/xtools/icfit/icdosetupr.x b/pkg/xtools/icfit/icdosetupr.x new file mode 100644 index 00000000..2039560d --- /dev/null +++ b/pkg/xtools/icfit/icdosetupr.x @@ -0,0 +1,121 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_DOSETUP -- Setup the fit. This is called at the start of each call +# to ic_fit to update the fitting parameters if necessary. + +procedure ic_dosetupr (ic, cv, x, wts, npts, newx, newwts, newfunction, refit) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +real x[npts] # Ordinates of data +real wts[npts] # Weights +int npts # Number of points in data +int newx # New x points? +int newwts # New weights? +int newfunction # New function? +int refit # Use cvrefit? + +int ord +real xmin, xmax + +pointer rg_xrangesr() +#extern hd_power$t() +errchk rg_xrangesr + +begin + # Set sample points. + if ((newx == YES) || (newwts == YES)) { + if (npts == 0) + call error (0, "No data points for fit") + + call mfree (IC_XFIT(ic), TY_REAL) + call mfree (IC_YFIT(ic), TY_REAL) + call malloc (IC_XFIT(ic), npts, TY_REAL) + + call mfree (IC_WTSFIT(ic), TY_REAL) + call malloc (IC_WTSFIT(ic), npts, TY_REAL) + + call mfree (IC_REJPTS(ic), TY_INT) + call malloc (IC_REJPTS(ic), npts, TY_INT) + call amovki (NO, Memi[IC_REJPTS(ic)], npts) + IC_NREJECT(ic) = 0 + + # Set sample points. + + call rg_free (IC_RG(ic)) + IC_RG(ic) = rg_xrangesr (Memc[IC_SAMPLE(ic)], x, npts) + call rg_order (IC_RG(ic)) + call rg_merge (IC_RG(ic)) + call rg_wtbinr (IC_RG(ic), max (1, abs (IC_NAVERAGE(ic))), x, wts, + npts, Memr[IC_XFIT(ic)], Memr[IC_WTSFIT(ic)], IC_NFIT(ic)) + + if (IC_NFIT(ic) == 0) + call error (0, "No sample points for fit") + + if (IC_NFIT(ic) == npts) { + call rg_free (IC_RG(ic)) + call mfree (IC_XFIT(ic), TY_REAL) + call mfree (IC_WTSFIT(ic), TY_REAL) + IC_YFIT(ic) = NULL + IC_WTSFIT(ic) = NULL + call alimr (x, npts, xmin, xmax) + } else { + call malloc (IC_YFIT(ic), IC_NFIT(ic), TY_REAL) + if (IC_NFIT(ic) == 1) + call alimr (x, npts, xmin, xmax) + else + call alimr (Memr[IC_XFIT(ic)], IC_NFIT(ic), xmin, xmax) + } + + IC_XMIN(ic) = min (IC_XMIN(ic), real(xmin)) + IC_XMAX(ic) = max (IC_XMAX(ic), real(xmax)) + refit = NO + } + + # Set curve fitting parameters. + # For polynomials define fitting range over range of data in fit + # and assume extrpolation is ok. For spline functions define + # fitting range to be range of evaluation set by the caller + # since extrapolation will not make sense. + + if ((newx == YES) || (newfunction == YES)) { + if (cv != NULL) + call rcvfree (cv) + + switch (IC_FUNCTION(ic)) { + case LEGENDRE, CHEBYSHEV: + ord = min (IC_ORDER(ic), IC_NFIT(ic)) + call rcvinit (cv, IC_FUNCTION(ic), ord, real (xmin), + real (xmax)) + case SPLINE1: + ord = min (IC_ORDER(ic), IC_NFIT(ic) - 1) + if (ord > 0) + call rcvinit (cv, SPLINE1, ord, real (IC_XMIN(ic)), + real (IC_XMAX(ic))) + else + call rcvinit (cv, LEGENDRE, IC_NFIT(ic), + real (IC_XMIN(ic)), real (IC_XMAX(ic))) + case SPLINE3: + ord = min (IC_ORDER(ic), IC_NFIT(ic) - 3) + if (ord > 0) + call rcvinit (cv, SPLINE3, ord, real (IC_XMIN(ic)), + real (IC_XMAX(ic))) + else + call rcvinit (cv, LEGENDRE, IC_NFIT(ic), + real (IC_XMIN(ic)), real (IC_XMAX(ic))) +# case USERFNC: +# ord = min (IC_ORDER(ic), IC_NFIT(ic)) +# call $tcvinit (cv, USERFNC, ord, PIXEL (IC_XMIN(ic)), +# PIXEL (IC_XMAX(ic))) +# call $tcvuserfnc (cv, hd_power$t) + default: + call error (0, "Unknown fitting function") + } + + refit = NO + } +end diff --git a/pkg/xtools/icfit/icerrors.gx b/pkg/xtools/icfit/icerrors.gx new file mode 100644 index 00000000..114349e3 --- /dev/null +++ b/pkg/xtools/icfit/icerrors.gx @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "names.h" + +# IC_ERRORS -- Compute and error diagnositic information. + +procedure ic_errors$t (ic, file, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +char file[ARB] # Output file +pointer cv # Curfit pointer +PIXEL x[ARB] # Ordinates +PIXEL y[ARB] # Abscissas +PIXEL wts[ARB] # Weights +int npts # Number of data points + +int fd, open() +errchk open, ic_ferrors$t + +begin + fd = open (file, APPEND, TEXT_FILE) + call ic_ferrors$t (ic, cv, x, y, wts, npts, fd) + call close (fd) +end diff --git a/pkg/xtools/icfit/icerrorsd.x b/pkg/xtools/icfit/icerrorsd.x new file mode 100644 index 00000000..763c7c4d --- /dev/null +++ b/pkg/xtools/icfit/icerrorsd.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "names.h" + +# IC_ERRORS -- Compute and error diagnositic information. + +procedure ic_errorsd (ic, file, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +char file[ARB] # Output file +pointer cv # Curfit pointer +double x[ARB] # Ordinates +double y[ARB] # Abscissas +double wts[ARB] # Weights +int npts # Number of data points + +int fd, open() +errchk open, ic_ferrorsd + +begin + fd = open (file, APPEND, TEXT_FILE) + call ic_ferrorsd (ic, cv, x, y, wts, npts, fd) + call close (fd) +end diff --git a/pkg/xtools/icfit/icerrorsr.x b/pkg/xtools/icfit/icerrorsr.x new file mode 100644 index 00000000..def6f603 --- /dev/null +++ b/pkg/xtools/icfit/icerrorsr.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "names.h" + +# IC_ERRORS -- Compute and error diagnositic information. + +procedure ic_errorsr (ic, file, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +char file[ARB] # Output file +pointer cv # Curfit pointer +real x[ARB] # Ordinates +real y[ARB] # Abscissas +real wts[ARB] # Weights +int npts # Number of data points + +int fd, open() +errchk open, ic_ferrorsr + +begin + fd = open (file, APPEND, TEXT_FILE) + call ic_ferrorsr (ic, cv, x, y, wts, npts, fd) + call close (fd) +end diff --git a/pkg/xtools/icfit/icferrors.gx b/pkg/xtools/icfit/icferrors.gx new file mode 100644 index 00000000..4c7ef109 --- /dev/null +++ b/pkg/xtools/icfit/icferrors.gx @@ -0,0 +1,141 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_FERRORS -- Compute error diagnositic information. + +procedure ic_ferrors$t (ic, cv, x, y, wts, npts, fd) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +PIXEL x[ARB] # Ordinates +PIXEL y[ARB] # Abscissas +PIXEL wts[ARB] # Weights +int npts # Number of data points +int fd # Output file descriptor + +int i, n, deleted, ncoeffs +PIXEL chisqr, rms +pointer sp, fit, wts1, coeffs, errors + +int $tcvstati() +PIXEL ic_rms$t() + +begin + # Determine the number of coefficients and allocate memory. + + ncoeffs = $tcvstati (cv, CVNCOEFF) + call smark (sp) + call salloc (coeffs, ncoeffs, TY_PIXEL) + call salloc (errors, ncoeffs, TY_PIXEL) + + if (npts == IC_NFIT(ic)) { + # Allocate memory for the fit. + + n = npts + call salloc (fit, n, TY_PIXEL) + call salloc (wts1, n, TY_PIXEL) + + # Eliminate rejected points and count deleted points. + + call amov$t (wts, Mem$t[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Mem$t[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call $tcvvector (cv, x, Mem$t[fit], n) + call $tcvcoeff (cv, Mem$t[coeffs], ncoeffs) + call $tcverrors (cv, y, Mem$t[wts1], Mem$t[fit], n, chisqr, + Mem$t[errors]) + rms = ic_rms$t (x, y, Mem$t[fit], Mem$t[wts1], n) + } else { + # Allocate memory for the fit. + + n = IC_NFIT(ic) + call salloc (fit, n, TY_PIXEL) + call salloc (wts1, n, TY_PIXEL) + + # Eliminate rejected points and count deleted points. + + call amov$t (Mem$t[IC_WTSFIT(ic)], Mem$t[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Mem$t[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call $tcvvector (cv, Mem$t[IC_XFIT(ic)], Mem$t[fit], n) + rms = ic_rms$t (Mem$t[IC_XFIT(ic)], Mem$t[IC_YFIT(ic)], + Mem$t[fit], Mem$t[wts1], n) + call $tcvcoeff (cv, Mem$t[coeffs], ncoeffs) + call $tcverrors (cv, Mem$t[IC_YFIT(ic)], Mem$t[wts1], Mem$t[fit], + n, chisqr, Mem$t[errors]) + } + + # Print the error analysis. + + call fprintf (fd, "# total points = %d\nsample points = %d\n") + call pargi (npts) + call pargi (n) + call fprintf (fd, "# nrejected = %d\ndeleted = %d\n") + call pargi (IC_NREJECT(ic)) + call pargi (deleted) + call fprintf (fd, "# RMS = %7.4g\n") + call parg$t (rms) + call fprintf (fd, "# square root of reduced chi square = %7.4g\n") + call parg$t (sqrt (chisqr)) + + # Free allocated memory. + + call sfree (sp) +end + +# IC_RMS -- Compute RMS of points which have not been deleted. + +PIXEL procedure ic_rms$t (x, y, fit, wts, npts) + +PIXEL x[ARB] # Ordinates +PIXEL y[ARB] # Abscissas +PIXEL fit[ARB] # Fit +PIXEL wts[ARB] # Weights +int npts # Number of data points + +int i, n +PIXEL resid, rms + +begin + rms = 0. + n = 0 + do i = 1, npts { + if (wts[i] == 0.) + next + resid = y[i] - fit[i] + rms = rms + resid * resid + n = n + 1 + } + + if (n > 0) + rms = sqrt (rms / n) + + return (rms) +end diff --git a/pkg/xtools/icfit/icferrorsd.x b/pkg/xtools/icfit/icferrorsd.x new file mode 100644 index 00000000..03a5523c --- /dev/null +++ b/pkg/xtools/icfit/icferrorsd.x @@ -0,0 +1,141 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_FERRORS -- Compute error diagnositic information. + +procedure ic_ferrorsd (ic, cv, x, y, wts, npts, fd) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +double x[ARB] # Ordinates +double y[ARB] # Abscissas +double wts[ARB] # Weights +int npts # Number of data points +int fd # Output file descriptor + +int i, n, deleted, ncoeffs +double chisqr, rms +pointer sp, fit, wts1, coeffs, errors + +int dcvstati() +double ic_rmsd() + +begin + # Determine the number of coefficients and allocate memory. + + ncoeffs = dcvstati (cv, CVNCOEFF) + call smark (sp) + call salloc (coeffs, ncoeffs, TY_DOUBLE) + call salloc (errors, ncoeffs, TY_DOUBLE) + + if (npts == IC_NFIT(ic)) { + # Allocate memory for the fit. + + n = npts + call salloc (fit, n, TY_DOUBLE) + call salloc (wts1, n, TY_DOUBLE) + + # Eliminate rejected points and count deleted points. + + call amovd (wts, Memd[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memd[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call dcvvector (cv, x, Memd[fit], n) + call dcvcoeff (cv, Memd[coeffs], ncoeffs) + call dcverrors (cv, y, Memd[wts1], Memd[fit], n, chisqr, + Memd[errors]) + rms = ic_rmsd (x, y, Memd[fit], Memd[wts1], n) + } else { + # Allocate memory for the fit. + + n = IC_NFIT(ic) + call salloc (fit, n, TY_DOUBLE) + call salloc (wts1, n, TY_DOUBLE) + + # Eliminate rejected points and count deleted points. + + call amovd (Memd[IC_WTSFIT(ic)], Memd[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memd[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call dcvvector (cv, Memd[IC_XFIT(ic)], Memd[fit], n) + rms = ic_rmsd (Memd[IC_XFIT(ic)], Memd[IC_YFIT(ic)], + Memd[fit], Memd[wts1], n) + call dcvcoeff (cv, Memd[coeffs], ncoeffs) + call dcverrors (cv, Memd[IC_YFIT(ic)], Memd[wts1], Memd[fit], + n, chisqr, Memd[errors]) + } + + # Print the error analysis. + + call fprintf (fd, "# total points = %d\nsample points = %d\n") + call pargi (npts) + call pargi (n) + call fprintf (fd, "# nrejected = %d\ndeleted = %d\n") + call pargi (IC_NREJECT(ic)) + call pargi (deleted) + call fprintf (fd, "# RMS = %7.4g\n") + call pargd (rms) + call fprintf (fd, "# square root of reduced chi square = %7.4g\n") + call pargd (sqrt (chisqr)) + + # Free allocated memory. + + call sfree (sp) +end + +# IC_RMS -- Compute RMS of points which have not been deleted. + +double procedure ic_rmsd (x, y, fit, wts, npts) + +double x[ARB] # Ordinates +double y[ARB] # Abscissas +double fit[ARB] # Fit +double wts[ARB] # Weights +int npts # Number of data points + +int i, n +double resid, rms + +begin + rms = 0. + n = 0 + do i = 1, npts { + if (wts[i] == 0.) + next + resid = y[i] - fit[i] + rms = rms + resid * resid + n = n + 1 + } + + if (n > 0) + rms = sqrt (rms / n) + + return (rms) +end diff --git a/pkg/xtools/icfit/icferrorsr.x b/pkg/xtools/icfit/icferrorsr.x new file mode 100644 index 00000000..61cf0d52 --- /dev/null +++ b/pkg/xtools/icfit/icferrorsr.x @@ -0,0 +1,141 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_FERRORS -- Compute error diagnositic information. + +procedure ic_ferrorsr (ic, cv, x, y, wts, npts, fd) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +real x[ARB] # Ordinates +real y[ARB] # Abscissas +real wts[ARB] # Weights +int npts # Number of data points +int fd # Output file descriptor + +int i, n, deleted, ncoeffs +real chisqr, rms +pointer sp, fit, wts1, coeffs, errors + +int rcvstati() +real ic_rmsr() + +begin + # Determine the number of coefficients and allocate memory. + + ncoeffs = rcvstati (cv, CVNCOEFF) + call smark (sp) + call salloc (coeffs, ncoeffs, TY_REAL) + call salloc (errors, ncoeffs, TY_REAL) + + if (npts == IC_NFIT(ic)) { + # Allocate memory for the fit. + + n = npts + call salloc (fit, n, TY_REAL) + call salloc (wts1, n, TY_REAL) + + # Eliminate rejected points and count deleted points. + + call amovr (wts, Memr[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memr[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call rcvvector (cv, x, Memr[fit], n) + call rcvcoeff (cv, Memr[coeffs], ncoeffs) + call rcverrors (cv, y, Memr[wts1], Memr[fit], n, chisqr, + Memr[errors]) + rms = ic_rmsr (x, y, Memr[fit], Memr[wts1], n) + } else { + # Allocate memory for the fit. + + n = IC_NFIT(ic) + call salloc (fit, n, TY_REAL) + call salloc (wts1, n, TY_REAL) + + # Eliminate rejected points and count deleted points. + + call amovr (Memr[IC_WTSFIT(ic)], Memr[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memr[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call rcvvector (cv, Memr[IC_XFIT(ic)], Memr[fit], n) + rms = ic_rmsr (Memr[IC_XFIT(ic)], Memr[IC_YFIT(ic)], + Memr[fit], Memr[wts1], n) + call rcvcoeff (cv, Memr[coeffs], ncoeffs) + call rcverrors (cv, Memr[IC_YFIT(ic)], Memr[wts1], Memr[fit], + n, chisqr, Memr[errors]) + } + + # Print the error analysis. + + call fprintf (fd, "# total points = %d\nsample points = %d\n") + call pargi (npts) + call pargi (n) + call fprintf (fd, "# nrejected = %d\ndeleted = %d\n") + call pargi (IC_NREJECT(ic)) + call pargi (deleted) + call fprintf (fd, "# RMS = %7.4g\n") + call pargr (rms) + call fprintf (fd, "# square root of reduced chi square = %7.4g\n") + call pargr (sqrt (chisqr)) + + # Free allocated memory. + + call sfree (sp) +end + +# IC_RMS -- Compute RMS of points which have not been deleted. + +real procedure ic_rmsr (x, y, fit, wts, npts) + +real x[ARB] # Ordinates +real y[ARB] # Abscissas +real fit[ARB] # Fit +real wts[ARB] # Weights +int npts # Number of data points + +int i, n +real resid, rms + +begin + rms = 0. + n = 0 + do i = 1, npts { + if (wts[i] == 0.) + next + resid = y[i] - fit[i] + rms = rms + resid * resid + n = n + 1 + } + + if (n > 0) + rms = sqrt (rms / n) + + return (rms) +end diff --git a/pkg/xtools/icfit/icfit.gx b/pkg/xtools/icfit/icfit.gx new file mode 100644 index 00000000..2c301360 --- /dev/null +++ b/pkg/xtools/icfit/icfit.gx @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +include <error.h> +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_FIT -- Fit a function. This is the main fitting task. It uses +# flags to define changes since the last fit. This allows the most +# efficient use of the curfit and ranges packages. + +procedure ic_fit$t (ic, cv, x, y, wts, npts, newx, newy, newwts, newfunction) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +PIXEL x[npts] # Ordinates +PIXEL y[npts] # Data to be fit +PIXEL wts[npts] # Weights +int npts # Number of points +int newx # New x points? +int newy # New y points? +int newwts # New weights? +int newfunction # New function? + +int ier, refit + +errchk ic_dosetup$t, $tcvfit, $tcvrefit, rg_wtbin$t, ic_reject$t + +begin + IC_FITERROR(ic) = NO + + iferr { + # Setup the new parameters. + + call ic_dosetup$t (ic, cv, x, wts, npts, newx, newwts, newfunction, + refit) + + # If not sampling use the data array directly. + + if (npts == IC_NFIT(ic)) { + if (refit == NO) { + call $tcvfit (cv, x, y, wts, npts, WTS_USER, ier) + } else if (newy == YES) + call $tcvrefit (cv, x, y, wts, ier) + + # If sampling first form the sample y values. + + } else { + if ((newx == YES) || (newy == YES) || (newwts == YES)) + call rg_wtbin$t (IC_RG(ic), IC_NAVERAGE(ic), y, wts, npts, + Mem$t[IC_YFIT(ic)], Mem$t[IC_WTSFIT(ic)], IC_NFIT(ic)) + if (refit == NO) { + call $tcvfit (cv, Mem$t[IC_XFIT(ic)], Mem$t[IC_YFIT(ic)], + Mem$t[IC_WTSFIT(ic)], IC_NFIT(ic), WTS_USER, ier) + } else if (newy == YES) + call $tcvrefit (cv, Mem$t[IC_XFIT(ic)], Mem$t[IC_YFIT(ic)], + Mem$t[IC_WTSFIT(ic)], ier) + } + + # Check for an error in the fit. + + switch (ier) { + case SINGULAR: + call printf ("Singular solution\n") + call flush (STDOUT) + case NO_DEG_FREEDOM: + call printf ("No degrees of freedom\n") + call flush (STDOUT) + IC_FITERROR(ic) = YES + } + + if (IC_FITERROR(ic) == NO) { + refit = YES + + # Do pixel rejection if desired. + + if ((IC_LOW(ic) > 0.) || (IC_HIGH(ic) > 0.)) { + if (npts == IC_NFIT(ic)) + call ic_reject$t (cv, x, y, wts, Memi[IC_REJPTS(ic)], + IC_NFIT(ic), IC_LOW(ic), IC_HIGH(ic), + IC_NITERATE(ic), IC_GROW(ic), IC_NREJECT(ic)) + else + call ic_reject$t (cv, Mem$t[IC_XFIT(ic)], + Mem$t[IC_YFIT(ic)], Mem$t[IC_WTSFIT(ic)], + Memi[IC_REJPTS(ic)], IC_NFIT(ic), IC_LOW(ic), + IC_HIGH(ic), IC_NITERATE(ic), IC_GROW(ic), + IC_NREJECT(ic)) + + if (IC_NREJECT(ic) > 0) + refit = NO + } else + IC_NREJECT(ic) = 0 + } + } then { + IC_FITERROR(ic) = YES + call erract (EA_ERROR) + } +end diff --git a/pkg/xtools/icfit/icfit.h b/pkg/xtools/icfit/icfit.h new file mode 100644 index 00000000..3ea9023c --- /dev/null +++ b/pkg/xtools/icfit/icfit.h @@ -0,0 +1,50 @@ +# The ICFIT data structure + +define IC_NGKEYS 5 # Number of graph keys +define IC_LENSTRUCT 44 # Length of ICFIT structure +define IC_SZSAMPLE 1024 # Size of sample string + +# User fitting parameters +define IC_FUNCTION Memi[$1] # Function type +define IC_ORDER Memi[$1+1] # Order of function +define IC_SAMPLE Memi[$1+2] # Pointer to sample string +define IC_NAVERAGE Memi[$1+3] # Sampling averaging bin +define IC_NITERATE Memi[$1+4] # Number of rejection interation +define IC_XMIN Memr[P2R($1+5)] # Minimum value for curve +define IC_XMAX Memr[P2R($1+6)] # Maximum value for curve +define IC_LOW Memr[P2R($1+7)] # Low rejection value +define IC_HIGH Memr[P2R($1+8)] # Low rejection value +define IC_GROW Memr[P2R($1+9)] # Rejection growing radius + +# ICFIT parameters used for fitting +define IC_NFIT Memi[$1+10] # Number of fit points +define IC_NREJECT Memi[$1+11] # Number of rejected points +define IC_RG Memi[$1+12] # Pointer for ranges +define IC_XFIT Memi[$1+13] # Pointer to ordinates of fit points +define IC_YFIT Memi[$1+14] # Pointer to abscissas of fit points +define IC_WTSFIT Memi[$1+15] # Pointer to weights of fit points +define IC_REJPTS Memi[$1+16] # Pointer to rejected points + +# ICFIT parameters used for interactive graphics +define IC_NEWX Memi[$1+17] # New x fit points? +define IC_NEWY Memi[$1+18] # New y points? +define IC_NEWWTS Memi[$1+19] # New weights? +define IC_NEWFUNCTION Memi[$1+20] # New fitting function? +define IC_COLOR Memi[$1+21] # Fit color +define IC_OVERPLOT Memi[$1+22] # Overplot next plot? +define IC_FITERROR Memi[$1+23] # Error in fit +define IC_MARKREJ Memi[$1+24] # Mark rejected points? +define IC_LABELS Memi[$1+25+$2-1]# Graph axis labels +define IC_UNITS Memi[$1+27+$2-1]# Graph axis units +define IC_HELP Memi[$1+29] # Pointer to help file name +define IC_GP Memi[$1+30] # GIO pointer +define IC_GT Memi[$1+31] # GTOOLS pointer + +# ICFIT key definitions +define IC_GKEY Memi[$1+32] # Graph key +define IC_AXES Memi[$1+33+($2-1)*2+$3-1] # Graph axis codes + +# Default help file and prompt +define IC_DEFHELP "noao$lib/scr/icgfit.key" +define IC_DEFHTML "noao$lib/scr/icgfit.html" +define IC_PROMPT "icfit cursor options" diff --git a/pkg/xtools/icfit/icfit.hlp b/pkg/xtools/icfit/icfit.hlp new file mode 100644 index 00000000..3461c9ff --- /dev/null +++ b/pkg/xtools/icfit/icfit.hlp @@ -0,0 +1,229 @@ +.help icfit Sep91 xtools.icfit +.ih +NAME +icfit -- Interactive curve fitting +.ih +SYNOPSIS +A number of application tasks use the interactive curve fitting tools based +on the \fBcurfit\fR package for fitting curves to data. Interactive graphical +curve fitting begins by graphing the data points and the current fit in one of +five formats. When the cursor appears the user may modify the graphs and the +fit in a number of ways with cursor mode keystrokes and colon commands. +These are described below. +.ih +CURSOR MODE +.ls ? +The terminal is cleared and a menu of cursor keys and colon commands is printed. +.le +.ls a +Add points to contrain the fit. When adding points a query is made to set +the weights. A large weight will force the fit to go near the added point. +The added points are internal to the fitting routine and are not returned +or otherwise available to the particular task using the ICFIT capability. +.le +.ls c +The coordinates of the data point nearest the cursor and the fitted value +are printed on the status line. +.le +.ls d +The data point nearest the cursor and not previously deleted is marked with an +X. It will not be used in futher fits unless it is undeleted. +.le +.ls f +A curve is fit to the data and the fit is graphed in the current format. +.le +.ls g +Redefine the graph keys "h-l" from their defaults. A prompt is given for the +graph key which is to be redefined and then for the graph desired. +A '?' to either prompt prints help information. A graph +is given by a pair of comma separated data types. The first data type defines +the horizontal axis and the second defines the vertical axis. Any of the +data types may be graphed along either axis. The data types are +.nf + x Independent variable y Dependent variable + f Fitted value r Residual (y - f) + d Ratio (y / f) n Nonlinear part of y +.fi +.le +.ls h, i, j, k, l +Each key produces a different graph. The graphs are described by the data +which is graphed along each axis as defined above. The default graph keys +(which may be redefined with the 'g' key) are h=(x,y), i=(y,x), j=(x,r), +k=(x,d), l=(x,n). +.le +.ls o +Overplot the next fit provided the graph format is not changed. +.le +.ls q +Exit from the interactive curve fitting. Two consecutive carriage returns +(cursor end-of-file) may also be used. +.le +.ls r +Redraw the current graph. +.le +.ls s +Select a sample range. Set the cursor at one end point of the sample before +typing 's' and then set the cursor to the other endpoint and type any key +in response to the prompt "again:". Sample ranges are intersected unless +the sample ranges have been initialized to all the points with the key 't'. +.le +.ls t +Initialize the sample to include all data points. +.le +.ls u +Undelete the data point nearest the cursor which was previously deleted. +.le +.ls v +Change the fitting weight of the point nearest the cursor. +.le +.ls w +Set the graph window (range along each axis to be graphed). This is a +\fBgtools\fR option which prints the prompt "window:". The set of cursor +keys is printed with '?' and help is available under the keyword \fBgtools\fR. +.le +.ls x +Change the x value of the point nearest the cursor. +.le +.ls y +Change the y value of the point nearest the cursor. +.le +.ls z +Delete the nearest sample region to the cursor. +.le +.ih +COLON COMMANDS +Colon commands are show or set the values of parameters. The parameter names +may be abbreviated as may the function type. + +.ls :show [file] +Show the current values of all the fitting parameters. The default output +is the terminal (STDOUT) and the screen is cleared before the information +is output. If a file is specified then the information is appended to the +named file. +.le +.ls :vshow [file] +A verbose version of "show" which includes the fitted coefficients and their +errors. +.le +.ls :evaluate <value> +Evaluate the fit at the specified value and print the result on the status +line. +.le +.ls :xyshow [file] +List the independent (X), dependent (y), fitted (Y fit), and weight values. +The output may be listed on the screen or to a file. Note that if the +original input is combined into composit points (\fInaverage\fR not 1) +then the values are for the composite points. Deleted points will have +a weight of zero. +.le +.ls :errors [file] +Show the fitted function and square root of the chi square of the fit. +The default output +is the terminal (STDOUT) and the screen is cleared before the information +is output. If a file is specified then the information is appended to the +named file. +.le +.ls :function [value] +Show the current value or set the function type. The functions types are +"chebyshev", "legendre", "spline1", or "spline3" for chebyshev or legendre +polynomial or linear or cubic spline. +.le +.ls :grow [value] +Show the current value or set the rejection growing radius. Any points within +this distance of rejected points are also rejected. +.le +.ls :color [value=0-9] +Color of fit where 0=background (invisible), 1=foreground, and higher +numbers depend on the graphics device. Note that this applies to the +fit and to change the color of the data use ":/color". +.le +.ls :markrej [value] +Mark rejected points? If there are many rejected points then it might be +desired not to mark the points. +.le +.ls :naverage [value] +Show the current value or set the number of points to average or median to form +fitting points. A positive value select an mean and negative values select +a median. The averaged points are also shown in the graphs. +.le +.ls :order [value] +Show the current value or set the order of the function. For legendre or +chebyshev polynomials the order is the number of terms (i.e. an order of 2 +has two terms and is a linear function). For the splines the order is the +number of spline pieces. +.le +.ls :low_reject [value], :high_reject [value] +Show the current values or set the rejection limits. When a fit is made +if the rejection threshold is greater than zero then the sigma of the +residuals about the fit is computed. Points with residuals more than +this number of times the sigma are removed from the final fit. These +points are marked on the graphs with diamonds. +.le +.ls :niterate [value] +Show the current value or set a new value for the number of rejection +iterations. +.le +.ls :sample [value] +Show the current value or set the sample points to use in the fits. This +parameter is a string consisting of single points, colon separated ranges, +or "*" to indicate all points. A file containing sample strings may also +be specified by prefixing the file name with the character '@'. +Note that sample ranges may also be set with the cursor mode key 's'. +.le +.ih +DESCRIPTION +A one dimensional function is fit to a set of x and y data points. +The function may be a legendre polynomial, chebyshev polynomial, +linear spline, or cubic spline of a given order or number of spline pieces. + +The points fit are determined by selecting a sample of data specified by +the parameter \fIsample\fR and taking either the average or median of +the number of points specified by the parameter \fInaverage\fR. +The type of averaging is selected by the sign of the parameter and the number +of points is selected by the absolute value of the parameter. + +If \fIniterate\fR is greater than zero the sigma +of the residuals between the fitted points and the fitted function is computed +and those points whose residuals are less than \fI-low_reject\fR * sigma +or \fIhigh_reject\fR * sigma value are excluded from the fit. Points within +a distance of \fIgrow\fR pixels of a rejected pixel are also excluded from +the fit. The function is then refit without the rejected points. +The rejection can be iterated the number of times specified by the parameter +\fIniterate\fR. Note a rejection value of zero is the same as no rejection. +The rejected points may be marked with diamonds. The marking of rejected +points is controlled by the :markrej command. + +There are five types or formats of graphs selected by the keys 'h', 'i', 'j', +'k', and 'l'. The graphs are defined by what is plotted on each axis of the +graph. There are six data types, any of which may be plotted on either axis. +These data types are the independent data points (x), the dependent data +points (y), the fitted values (f), the residuals (r=y-f), the +ratio of the data to the fit (d=y/f), and the data with the linear term +of the fit (determined by the endpoints of the fit) subtracted. The +default graph keys are shown in the cursor key section though the definitions +may be modified by the application. The user may also redefine the graph +keys using the 'g' key. This gives a choice of 36 different graph types. + +It is important to remember that changing the value of a fitting +parameter does not change the fit until 'f' is typed. +.ih +NOTES +The sample region is stored internally as a string of length 1024 characters. +This is greatly increased over versions prior to V2.10. However, due +to the fixed default size of string parameters in parameter files (160 +characters), initial sample regions input with a CL parameter are limited +to this smaller length string. The limitation may be escaped by using +the new capability of specifying a file containing ranges. Also sample +regions initialize by a task parameter may be extended interactively. +.ih +REVISIONS +.ls ICFIT V2.11 +The :xyshow output was modified to 1) not include colon labels, +2) print (X, Y, Y fit, Weight) instead of (X, Y fit, Y), and 3) +the printed values are those actually used in the fit when using +composite points (naverage not 1). +.le +.ih +SEE ALSO +gtools +.endhelp diff --git a/pkg/xtools/icfit/icfitd.x b/pkg/xtools/icfit/icfitd.x new file mode 100644 index 00000000..88a0e66f --- /dev/null +++ b/pkg/xtools/icfit/icfitd.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +include <error.h> +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_FIT -- Fit a function. This is the main fitting task. It uses +# flags to define changes since the last fit. This allows the most +# efficient use of the curfit and ranges packages. + +procedure ic_fitd (ic, cv, x, y, wts, npts, newx, newy, newwts, newfunction) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +double x[npts] # Ordinates +double y[npts] # Data to be fit +double wts[npts] # Weights +int npts # Number of points +int newx # New x points? +int newy # New y points? +int newwts # New weights? +int newfunction # New function? + +int ier, refit + +errchk ic_dosetupd, dcvfit, dcvrefit, rg_wtbind, ic_rejectd + +begin + IC_FITERROR(ic) = NO + + iferr { + # Setup the new parameters. + + call ic_dosetupd (ic, cv, x, wts, npts, newx, newwts, newfunction, + refit) + + # If not sampling use the data array directly. + + if (npts == IC_NFIT(ic)) { + if (refit == NO) { + call dcvfit (cv, x, y, wts, npts, WTS_USER, ier) + } else if (newy == YES) + call dcvrefit (cv, x, y, wts, ier) + + # If sampling first form the sample y values. + + } else { + if ((newx == YES) || (newy == YES) || (newwts == YES)) + call rg_wtbind (IC_RG(ic), IC_NAVERAGE(ic), y, wts, npts, + Memd[IC_YFIT(ic)], Memd[IC_WTSFIT(ic)], IC_NFIT(ic)) + if (refit == NO) { + call dcvfit (cv, Memd[IC_XFIT(ic)], Memd[IC_YFIT(ic)], + Memd[IC_WTSFIT(ic)], IC_NFIT(ic), WTS_USER, ier) + } else if (newy == YES) + call dcvrefit (cv, Memd[IC_XFIT(ic)], Memd[IC_YFIT(ic)], + Memd[IC_WTSFIT(ic)], ier) + } + + # Check for an error in the fit. + + switch (ier) { + case SINGULAR: + call printf ("Singular solution\n") + call flush (STDOUT) + case NO_DEG_FREEDOM: + call printf ("No degrees of freedom\n") + call flush (STDOUT) + IC_FITERROR(ic) = YES + } + + if (IC_FITERROR(ic) == NO) { + refit = YES + + # Do pixel rejection if desired. + + if ((IC_LOW(ic) > 0.) || (IC_HIGH(ic) > 0.)) { + if (npts == IC_NFIT(ic)) + call ic_rejectd (cv, x, y, wts, Memi[IC_REJPTS(ic)], + IC_NFIT(ic), IC_LOW(ic), IC_HIGH(ic), + IC_NITERATE(ic), IC_GROW(ic), IC_NREJECT(ic)) + else + call ic_rejectd (cv, Memd[IC_XFIT(ic)], + Memd[IC_YFIT(ic)], Memd[IC_WTSFIT(ic)], + Memi[IC_REJPTS(ic)], IC_NFIT(ic), IC_LOW(ic), + IC_HIGH(ic), IC_NITERATE(ic), IC_GROW(ic), + IC_NREJECT(ic)) + + if (IC_NREJECT(ic) > 0) + refit = NO + } else + IC_NREJECT(ic) = 0 + } + } then { + IC_FITERROR(ic) = YES + call erract (EA_ERROR) + } +end diff --git a/pkg/xtools/icfit/icfitr.x b/pkg/xtools/icfit/icfitr.x new file mode 100644 index 00000000..96344ffd --- /dev/null +++ b/pkg/xtools/icfit/icfitr.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +include <error.h> +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_FIT -- Fit a function. This is the main fitting task. It uses +# flags to define changes since the last fit. This allows the most +# efficient use of the curfit and ranges packages. + +procedure ic_fitr (ic, cv, x, y, wts, npts, newx, newy, newwts, newfunction) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +real x[npts] # Ordinates +real y[npts] # Data to be fit +real wts[npts] # Weights +int npts # Number of points +int newx # New x points? +int newy # New y points? +int newwts # New weights? +int newfunction # New function? + +int ier, refit + +errchk ic_dosetupr, rcvfit, rcvrefit, rg_wtbinr, ic_rejectr + +begin + IC_FITERROR(ic) = NO + + iferr { + # Setup the new parameters. + + call ic_dosetupr (ic, cv, x, wts, npts, newx, newwts, newfunction, + refit) + + # If not sampling use the data array directly. + + if (npts == IC_NFIT(ic)) { + if (refit == NO) { + call rcvfit (cv, x, y, wts, npts, WTS_USER, ier) + } else if (newy == YES) + call rcvrefit (cv, x, y, wts, ier) + + # If sampling first form the sample y values. + + } else { + if ((newx == YES) || (newy == YES) || (newwts == YES)) + call rg_wtbinr (IC_RG(ic), IC_NAVERAGE(ic), y, wts, npts, + Memr[IC_YFIT(ic)], Memr[IC_WTSFIT(ic)], IC_NFIT(ic)) + if (refit == NO) { + call rcvfit (cv, Memr[IC_XFIT(ic)], Memr[IC_YFIT(ic)], + Memr[IC_WTSFIT(ic)], IC_NFIT(ic), WTS_USER, ier) + } else if (newy == YES) + call rcvrefit (cv, Memr[IC_XFIT(ic)], Memr[IC_YFIT(ic)], + Memr[IC_WTSFIT(ic)], ier) + } + + # Check for an error in the fit. + + switch (ier) { + case SINGULAR: + call printf ("Singular solution\n") + call flush (STDOUT) + case NO_DEG_FREEDOM: + call printf ("No degrees of freedom\n") + call flush (STDOUT) + IC_FITERROR(ic) = YES + } + + if (IC_FITERROR(ic) == NO) { + refit = YES + + # Do pixel rejection if desired. + + if ((IC_LOW(ic) > 0.) || (IC_HIGH(ic) > 0.)) { + if (npts == IC_NFIT(ic)) + call ic_rejectr (cv, x, y, wts, Memi[IC_REJPTS(ic)], + IC_NFIT(ic), IC_LOW(ic), IC_HIGH(ic), + IC_NITERATE(ic), IC_GROW(ic), IC_NREJECT(ic)) + else + call ic_rejectr (cv, Memr[IC_XFIT(ic)], + Memr[IC_YFIT(ic)], Memr[IC_WTSFIT(ic)], + Memi[IC_REJPTS(ic)], IC_NFIT(ic), IC_LOW(ic), + IC_HIGH(ic), IC_NITERATE(ic), IC_GROW(ic), + IC_NREJECT(ic)) + + if (IC_NREJECT(ic) > 0) + refit = NO + } else + IC_NREJECT(ic) = 0 + } + } then { + IC_FITERROR(ic) = YES + call erract (EA_ERROR) + } +end diff --git a/pkg/xtools/icfit/icfshow.x b/pkg/xtools/icfit/icfshow.x new file mode 100644 index 00000000..ced7bdaf --- /dev/null +++ b/pkg/xtools/icfit/icfshow.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/gtools.h> +include "icfit.h" + +# IC_FSHOW -- Show the values of the parameters. + +procedure ic_fshow (ic, fd) + +pointer ic # ICFIT pointer +int fd # Output file + +pointer str, ptr +long clktime() + +begin + call malloc (str, SZ_LINE, TY_CHAR) + + call cnvtime (clktime(0), Memc[str], SZ_LINE) + call fprintf (fd, "\n# %s\n") + call pargstr (Memc[str]) + + if (IC_GT(ic) != NULL) { + # The title may contain new lines so we have to put comments + # in front of each line. + call gt_gets (IC_GT(ic), GTTITLE, Memc[str], SZ_LINE) + call putline (fd, "# ") + for (ptr=str; Memc[ptr]!=EOS; ptr=ptr+1) { + call putc (fd, Memc[ptr]) + if (Memc[ptr] == '\n') { + call putline (fd, "# ") + } + } + call putline (fd, "\n") + + call gt_gets (IC_GT(ic), GTYUNITS, Memc[str], SZ_LINE) + if (Memc[str] != EOS) { + call fprintf (fd, "# fit units = %s\n") + call pargstr (Memc[str]) + } + } + + call ic_gstr (ic, "function", Memc[str], SZ_LINE) + call fprintf (fd, "# function = %s\n") + call pargstr (Memc[str]) + call fprintf (fd, "# grow = %g\n") + call pargr (IC_GROW(ic)) + call fprintf (fd, "# naverage = %d\n") + call pargi (IC_NAVERAGE(ic)) + call fprintf (fd, "# order = %d\n") + call pargi (IC_ORDER(ic)) + call fprintf (fd, "# low_reject = %g\n") + call pargr (IC_LOW(ic)) + call fprintf (fd, "# high_reject = %g\n") + call pargr (IC_HIGH(ic)) + call fprintf (fd, "# niterate = %d\n") + call pargi (IC_NITERATE(ic)) + call fprintf (fd, "# sample = %s\n") + call pargstr (Memc[IC_SAMPLE(ic)]) + + call mfree (str, TY_CHAR) +end diff --git a/pkg/xtools/icfit/icfvshow.gx b/pkg/xtools/icfit/icfvshow.gx new file mode 100644 index 00000000..458c0664 --- /dev/null +++ b/pkg/xtools/icfit/icfvshow.gx @@ -0,0 +1,164 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_FVSHOW -- Show fit parameters in verbose mode. + +procedure ic_fvshow$t (ic, cv, x, y, wts, npts, fd) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +PIXEL x[ARB] # Ordinates +PIXEL y[ARB] # Abscissas +PIXEL wts[ARB] # Weights +int npts # Number of data points +int fd # Output descriptor + +int i, n, deleted, ncoeffs +PIXEL chisqr, rms +pointer sp, fit, wts1, coeffs, errors + +int $tcvstati() +PIXEL ic_rms$t() + +begin + # Do the standard ic_show option, then add on the verbose part. + call ic_fshow (ic, fd) + + if (npts == 0) { + call eprintf ("# Incomplete output - no data points for fit\n") + return + } + + # Determine the number of coefficients and allocate memory. + + ncoeffs = $tcvstati (cv, CVNCOEFF) + call smark (sp) + call salloc (coeffs, ncoeffs, TY_PIXEL) + call salloc (errors, ncoeffs, TY_PIXEL) + + if (npts == IC_NFIT(ic)) { + # Allocate memory for the fit. + + n = npts + call salloc (fit, n, TY_PIXEL) + call salloc (wts1, n, TY_PIXEL) + + # Eliminate rejected points and count deleted points. + + call amov$t (wts, Mem$t[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Mem$t[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call $tcvvector (cv, x, Mem$t[fit], n) + call $tcvcoeff (cv, Mem$t[coeffs], ncoeffs) + call $tcverrors (cv, y, Mem$t[wts1], Mem$t[fit], n, chisqr, + Mem$t[errors]) + rms = ic_rms$t (x, y, Mem$t[fit], Mem$t[wts1], n) + } else { + # Allocate memory for the fit. + + n = IC_NFIT(ic) + call salloc (fit, n, TY_PIXEL) + call salloc (wts1, n, TY_PIXEL) + + # Eliminate rejected points and count deleted points. + + call amov$t (Mem$t[IC_WTSFIT(ic)], Mem$t[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Mem$t[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call $tcvvector (cv, Mem$t[IC_XFIT(ic)], Mem$t[fit], n) + rms = ic_rms$t (Mem$t[IC_XFIT(ic)], Mem$t[IC_YFIT(ic)], + Mem$t[fit], Mem$t[wts1], n) + call $tcvcoeff (cv, Mem$t[coeffs], ncoeffs) + call $tcverrors (cv, Mem$t[IC_YFIT(ic)], Mem$t[wts1], Mem$t[fit], + n, chisqr, Mem$t[errors]) + } + + # Print the error analysis. + + call fprintf (fd, "# total points = %d\n# sample points = %d\n") + call pargi (npts) + call pargi (n) + call fprintf (fd, "# nrejected = %d\n# deleted = %d\n") + call pargi (IC_NREJECT(ic)) + call pargi (deleted) + call fprintf (fd, "# RMS = %10.7g\n") + call parg$t (rms) + call fprintf (fd, "# square root of reduced chi square = %10.7g\n") + call parg$t (sqrt (chisqr)) + + call fprintf (fd, "# \t coefficent\t error\n") + do i = 1, ncoeffs { + call fprintf (fd, "# \t%14.7e\t%14.7e\n") + call parg$t (Mem$t[coeffs+i-1]) + call parg$t (Mem$t[errors+i-1]) + } + + # Free allocated memory. + + call sfree (sp) +end + + +# IC_FXYSHOW -- List data as x, y, fit, weight lines on output. + +procedure ic_fxyshow$t (ic, cv, x, y, w, npts, fd) + +pointer ic # ICFIT pointer +pointer cv # Pointer to curfit structure +PIXEL x[npts] # Array of x data values +PIXEL y[npts] # Array of y data values +PIXEL w[npts] # Array of weight data values +int npts # Number of data values +int fd # Output file descriptor + +int i +PIXEL $tcveval() + +begin + # List the data being fit (not necessarily the input data). + call fprintf (fd, "# X Y Y FIT WEIGHT\n") + if (npts == IC_NFIT(ic)) { + do i = 1, npts { + call fprintf (fd, "%8g %8g %8g %8g\n") + call parg$t (x[i]) + call parg$t (y[i]) + call parg$t ($tcveval (cv, x[i])) + call parg$t (w[i]) + } + } else { + do i = 1, IC_NFIT(ic) { + call fprintf (fd, "%8g %8g %8g %8g\n") + call parg$t (Mem$t[IC_XFIT(ic)+i-1]) + call parg$t (Mem$t[IC_YFIT(ic)+i-1]) + call parg$t ($tcveval (cv, Mem$t[IC_XFIT(ic)+i-1])) + call parg$t (Mem$t[IC_WTSFIT(ic)+i-1]) + } + } +end diff --git a/pkg/xtools/icfit/icfvshowd.x b/pkg/xtools/icfit/icfvshowd.x new file mode 100644 index 00000000..a26e0530 --- /dev/null +++ b/pkg/xtools/icfit/icfvshowd.x @@ -0,0 +1,164 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_FVSHOW -- Show fit parameters in verbose mode. + +procedure ic_fvshowd (ic, cv, x, y, wts, npts, fd) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +double x[ARB] # Ordinates +double y[ARB] # Abscissas +double wts[ARB] # Weights +int npts # Number of data points +int fd # Output descriptor + +int i, n, deleted, ncoeffs +double chisqr, rms +pointer sp, fit, wts1, coeffs, errors + +int dcvstati() +double ic_rmsd() + +begin + # Do the standard ic_show option, then add on the verbose part. + call ic_fshow (ic, fd) + + if (npts == 0) { + call eprintf ("# Incomplete output - no data points for fit\n") + return + } + + # Determine the number of coefficients and allocate memory. + + ncoeffs = dcvstati (cv, CVNCOEFF) + call smark (sp) + call salloc (coeffs, ncoeffs, TY_DOUBLE) + call salloc (errors, ncoeffs, TY_DOUBLE) + + if (npts == IC_NFIT(ic)) { + # Allocate memory for the fit. + + n = npts + call salloc (fit, n, TY_DOUBLE) + call salloc (wts1, n, TY_DOUBLE) + + # Eliminate rejected points and count deleted points. + + call amovd (wts, Memd[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memd[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call dcvvector (cv, x, Memd[fit], n) + call dcvcoeff (cv, Memd[coeffs], ncoeffs) + call dcverrors (cv, y, Memd[wts1], Memd[fit], n, chisqr, + Memd[errors]) + rms = ic_rmsd (x, y, Memd[fit], Memd[wts1], n) + } else { + # Allocate memory for the fit. + + n = IC_NFIT(ic) + call salloc (fit, n, TY_DOUBLE) + call salloc (wts1, n, TY_DOUBLE) + + # Eliminate rejected points and count deleted points. + + call amovd (Memd[IC_WTSFIT(ic)], Memd[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memd[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call dcvvector (cv, Memd[IC_XFIT(ic)], Memd[fit], n) + rms = ic_rmsd (Memd[IC_XFIT(ic)], Memd[IC_YFIT(ic)], + Memd[fit], Memd[wts1], n) + call dcvcoeff (cv, Memd[coeffs], ncoeffs) + call dcverrors (cv, Memd[IC_YFIT(ic)], Memd[wts1], Memd[fit], + n, chisqr, Memd[errors]) + } + + # Print the error analysis. + + call fprintf (fd, "# total points = %d\n# sample points = %d\n") + call pargi (npts) + call pargi (n) + call fprintf (fd, "# nrejected = %d\n# deleted = %d\n") + call pargi (IC_NREJECT(ic)) + call pargi (deleted) + call fprintf (fd, "# RMS = %10.7g\n") + call pargd (rms) + call fprintf (fd, "# square root of reduced chi square = %10.7g\n") + call pargd (sqrt (chisqr)) + + call fprintf (fd, "# \t coefficent\t error\n") + do i = 1, ncoeffs { + call fprintf (fd, "# \t%14.7e\t%14.7e\n") + call pargd (Memd[coeffs+i-1]) + call pargd (Memd[errors+i-1]) + } + + # Free allocated memory. + + call sfree (sp) +end + + +# IC_FXYSHOW -- List data as x, y, fit, weight lines on output. + +procedure ic_fxyshowd (ic, cv, x, y, w, npts, fd) + +pointer ic # ICFIT pointer +pointer cv # Pointer to curfit structure +double x[npts] # Array of x data values +double y[npts] # Array of y data values +double w[npts] # Array of weight data values +int npts # Number of data values +int fd # Output file descriptor + +int i +double dcveval() + +begin + # List the data being fit (not necessarily the input data). + call fprintf (fd, "# X Y Y FIT WEIGHT\n") + if (npts == IC_NFIT(ic)) { + do i = 1, npts { + call fprintf (fd, "%8g %8g %8g %8g\n") + call pargd (x[i]) + call pargd (y[i]) + call pargd (dcveval (cv, x[i])) + call pargd (w[i]) + } + } else { + do i = 1, IC_NFIT(ic) { + call fprintf (fd, "%8g %8g %8g %8g\n") + call pargd (Memd[IC_XFIT(ic)+i-1]) + call pargd (Memd[IC_YFIT(ic)+i-1]) + call pargd (dcveval (cv, Memd[IC_XFIT(ic)+i-1])) + call pargd (Memd[IC_WTSFIT(ic)+i-1]) + } + } +end diff --git a/pkg/xtools/icfit/icfvshowr.x b/pkg/xtools/icfit/icfvshowr.x new file mode 100644 index 00000000..2d50020f --- /dev/null +++ b/pkg/xtools/icfit/icfvshowr.x @@ -0,0 +1,164 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "icfit.h" +include "names.h" + +# IC_FVSHOW -- Show fit parameters in verbose mode. + +procedure ic_fvshowr (ic, cv, x, y, wts, npts, fd) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +real x[ARB] # Ordinates +real y[ARB] # Abscissas +real wts[ARB] # Weights +int npts # Number of data points +int fd # Output descriptor + +int i, n, deleted, ncoeffs +real chisqr, rms +pointer sp, fit, wts1, coeffs, errors + +int rcvstati() +real ic_rmsr() + +begin + # Do the standard ic_show option, then add on the verbose part. + call ic_fshow (ic, fd) + + if (npts == 0) { + call eprintf ("# Incomplete output - no data points for fit\n") + return + } + + # Determine the number of coefficients and allocate memory. + + ncoeffs = rcvstati (cv, CVNCOEFF) + call smark (sp) + call salloc (coeffs, ncoeffs, TY_REAL) + call salloc (errors, ncoeffs, TY_REAL) + + if (npts == IC_NFIT(ic)) { + # Allocate memory for the fit. + + n = npts + call salloc (fit, n, TY_REAL) + call salloc (wts1, n, TY_REAL) + + # Eliminate rejected points and count deleted points. + + call amovr (wts, Memr[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memr[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call rcvvector (cv, x, Memr[fit], n) + call rcvcoeff (cv, Memr[coeffs], ncoeffs) + call rcverrors (cv, y, Memr[wts1], Memr[fit], n, chisqr, + Memr[errors]) + rms = ic_rmsr (x, y, Memr[fit], Memr[wts1], n) + } else { + # Allocate memory for the fit. + + n = IC_NFIT(ic) + call salloc (fit, n, TY_REAL) + call salloc (wts1, n, TY_REAL) + + # Eliminate rejected points and count deleted points. + + call amovr (Memr[IC_WTSFIT(ic)], Memr[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memr[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Get the coefficients and compute the errors. + + call rcvvector (cv, Memr[IC_XFIT(ic)], Memr[fit], n) + rms = ic_rmsr (Memr[IC_XFIT(ic)], Memr[IC_YFIT(ic)], + Memr[fit], Memr[wts1], n) + call rcvcoeff (cv, Memr[coeffs], ncoeffs) + call rcverrors (cv, Memr[IC_YFIT(ic)], Memr[wts1], Memr[fit], + n, chisqr, Memr[errors]) + } + + # Print the error analysis. + + call fprintf (fd, "# total points = %d\n# sample points = %d\n") + call pargi (npts) + call pargi (n) + call fprintf (fd, "# nrejected = %d\n# deleted = %d\n") + call pargi (IC_NREJECT(ic)) + call pargi (deleted) + call fprintf (fd, "# RMS = %10.7g\n") + call pargr (rms) + call fprintf (fd, "# square root of reduced chi square = %10.7g\n") + call pargr (sqrt (chisqr)) + + call fprintf (fd, "# \t coefficent\t error\n") + do i = 1, ncoeffs { + call fprintf (fd, "# \t%14.7e\t%14.7e\n") + call pargr (Memr[coeffs+i-1]) + call pargr (Memr[errors+i-1]) + } + + # Free allocated memory. + + call sfree (sp) +end + + +# IC_FXYSHOW -- List data as x, y, fit, weight lines on output. + +procedure ic_fxyshowr (ic, cv, x, y, w, npts, fd) + +pointer ic # ICFIT pointer +pointer cv # Pointer to curfit structure +real x[npts] # Array of x data values +real y[npts] # Array of y data values +real w[npts] # Array of weight data values +int npts # Number of data values +int fd # Output file descriptor + +int i +real rcveval() + +begin + # List the data being fit (not necessarily the input data). + call fprintf (fd, "# X Y Y FIT WEIGHT\n") + if (npts == IC_NFIT(ic)) { + do i = 1, npts { + call fprintf (fd, "%8g %8g %8g %8g\n") + call pargr (x[i]) + call pargr (y[i]) + call pargr (rcveval (cv, x[i])) + call pargr (w[i]) + } + } else { + do i = 1, IC_NFIT(ic) { + call fprintf (fd, "%8g %8g %8g %8g\n") + call pargr (Memr[IC_XFIT(ic)+i-1]) + call pargr (Memr[IC_YFIT(ic)+i-1]) + call pargr (rcveval (cv, Memr[IC_XFIT(ic)+i-1])) + call pargr (Memr[IC_WTSFIT(ic)+i-1]) + } + } +end diff --git a/pkg/xtools/icfit/icgadd.gx b/pkg/xtools/icfit/icgadd.gx new file mode 100644 index 00000000..aa0b45d5 --- /dev/null +++ b/pkg/xtools/icfit/icgadd.gx @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> + +define MSIZE 2. # Mark size + +# ICG_ADD -- Add a point. + +procedure icg_add$t (gp, wx, wy, wt, x, y, w1, w2, npts) + +pointer gp # GIO pointer +real wx # X point to insert +real wy # Y point to insert +real wt # Weight of point to add +PIXEL x[npts] # Independent variable +PIXEL y[npts] # Dependent variable +PIXEL w1[npts] # Current weights +PIXEL w2[npts] # Initial weights +int npts # Number of points + +int i, j + +begin + # Find the place to insert the new point. + if (x[1] < x[npts]) + for (i = npts; (i > 0) && (wx < x[i]); i = i - 1) + ; + else + for (i = npts; (i > 0) && (wx > x[i]); i = i - 1) + ; + + # Shift the data to insert the new point. + for (j = npts; j > i; j = j - 1) { + x[j+1] = x[j] + y[j+1] = y[j] + w1[j+1] = w1[j] + w2[j+1] = w2[j] + } + + # Add the new point and increment the number of points. + i = i + 1 + x[i] = wx + y[i] = wy + w1[i] = wt + w2[i] = wt + npts = npts + 1 + + # Mark the point + call gmark (gp, real (x[i]), real (y[i]), GM_PLUS, MSIZE, MSIZE) +end diff --git a/pkg/xtools/icfit/icgaddd.x b/pkg/xtools/icfit/icgaddd.x new file mode 100644 index 00000000..b32c6b5a --- /dev/null +++ b/pkg/xtools/icfit/icgaddd.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> + +define MSIZE 2. # Mark size + +# ICG_ADD -- Add a point. + +procedure icg_addd (gp, wx, wy, wt, x, y, w1, w2, npts) + +pointer gp # GIO pointer +real wx # X point to insert +real wy # Y point to insert +real wt # Weight of point to add +double x[npts] # Independent variable +double y[npts] # Dependent variable +double w1[npts] # Current weights +double w2[npts] # Initial weights +int npts # Number of points + +int i, j + +begin + # Find the place to insert the new point. + if (x[1] < x[npts]) + for (i = npts; (i > 0) && (wx < x[i]); i = i - 1) + ; + else + for (i = npts; (i > 0) && (wx > x[i]); i = i - 1) + ; + + # Shift the data to insert the new point. + for (j = npts; j > i; j = j - 1) { + x[j+1] = x[j] + y[j+1] = y[j] + w1[j+1] = w1[j] + w2[j+1] = w2[j] + } + + # Add the new point and increment the number of points. + i = i + 1 + x[i] = wx + y[i] = wy + w1[i] = wt + w2[i] = wt + npts = npts + 1 + + # Mark the point + call gmark (gp, real (x[i]), real (y[i]), GM_PLUS, MSIZE, MSIZE) +end diff --git a/pkg/xtools/icfit/icgaddr.x b/pkg/xtools/icfit/icgaddr.x new file mode 100644 index 00000000..4e09be1b --- /dev/null +++ b/pkg/xtools/icfit/icgaddr.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> + +define MSIZE 2. # Mark size + +# ICG_ADD -- Add a point. + +procedure icg_addr (gp, wx, wy, wt, x, y, w1, w2, npts) + +pointer gp # GIO pointer +real wx # X point to insert +real wy # Y point to insert +real wt # Weight of point to add +real x[npts] # Independent variable +real y[npts] # Dependent variable +real w1[npts] # Current weights +real w2[npts] # Initial weights +int npts # Number of points + +int i, j + +begin + # Find the place to insert the new point. + if (x[1] < x[npts]) + for (i = npts; (i > 0) && (wx < x[i]); i = i - 1) + ; + else + for (i = npts; (i > 0) && (wx > x[i]); i = i - 1) + ; + + # Shift the data to insert the new point. + for (j = npts; j > i; j = j - 1) { + x[j+1] = x[j] + y[j+1] = y[j] + w1[j+1] = w1[j] + w2[j+1] = w2[j] + } + + # Add the new point and increment the number of points. + i = i + 1 + x[i] = wx + y[i] = wy + w1[i] = wt + w2[i] = wt + npts = npts + 1 + + # Mark the point + call gmark (gp, real (x[i]), real (y[i]), GM_PLUS, MSIZE, MSIZE) +end diff --git a/pkg/xtools/icfit/icgaxes.gx b/pkg/xtools/icfit/icgaxes.gx new file mode 100644 index 00000000..0e3f6a55 --- /dev/null +++ b/pkg/xtools/icfit/icgaxes.gx @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/gtools.h> +include "icfit.h" +include "names.h" + +# ICG_AXES -- Set axes data. +# The applications program may set additional axes types. + +procedure icg_axes$t (ic, gt, cv, axis, x, y, z, npts) + +pointer ic # ICFIT pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +int axis # Output axis +PIXEL x[npts] # Independent variable +PIXEL y[npts] # Dependent variable +PIXEL z[npts] # Output values +int npts # Number of points + +int i, axistype, gtlabel[2], gtunits[2] +PIXEL a, b, xmin, xmax +pointer label, units + +PIXEL $tcveval(), icg_dvz$t() +errchk adiv$t() +extern icg_dvz$t() + +data gtlabel/GTXLABEL, GTYLABEL/ +data gtunits/GTXUNITS, GTYUNITS/ + +begin + axistype = IC_AXES(ic, IC_GKEY(ic), axis) + switch (axistype) { + case 'x': # Independent variable + call gt_sets (gt, gtlabel[axis], Memc[IC_LABELS(ic,1)]) + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,1)]) + call amov$t (x, z, npts) + case 'y': # Dependent variable + call gt_sets (gt, gtlabel[axis], Memc[IC_LABELS(ic,2)]) + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + call amov$t (y, z, npts) + case 'f': # Fitted values + call gt_sets (gt, gtlabel[axis], "fit") + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + call $tcvvector (cv, x, z, npts) + case 'r': # Residuals + call gt_sets (gt, gtlabel[axis], "residuals") + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + call $tcvvector (cv, x, z, npts) + call asub$t (y, z, z, npts) + case 'd': # Ratio + call gt_sets (gt, gtlabel[axis], "ratio") + call gt_sets (gt, gtunits[axis], "") + call $tcvvector (cv, x, z, npts) +# iferr (call adiv$t (y, z, z, npts)) + call advz$t (y, z, z, npts, icg_dvz$t) + case 'n': # Linear component removed + call gt_sets (gt, gtlabel[axis], "non-linear component") + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + xmin = IC_XMIN(ic) + xmax = IC_XMAX(ic) + a = $tcveval (cv, PIXEL (xmin)) + b = ($tcveval (cv, PIXEL (xmax)) - a) / (xmax - xmin) + do i = 1, npts + z[i] = y[i] - a - b * (x[i] - xmin) + case 'v': + call gt_sets (gt, gtlabel[axis], "Velocity") + call gt_sets (gt, gtunits[axis], "km/s") + call $tcvvector (cv, x, z, npts) + do i = 1, npts + z[i] = (z[i] - y[i]) / y[i] * 300000. + default: # User axes types. + call malloc (label, SZ_LINE, TY_CHAR) + call malloc (units, SZ_LINE, TY_CHAR) + if (axis == 1) { + call strcpy (Memc[IC_LABELS(ic,1)], Memc[label], SZ_LINE) + call strcpy (Memc[IC_UNITS(ic,1)], Memc[units], SZ_LINE) + call amov$t (x, z, npts) + } else { + call strcpy (Memc[IC_LABELS(ic,2)], Memc[label], SZ_LINE) + call strcpy (Memc[IC_UNITS(ic,2)], Memc[units], SZ_LINE) + call amov$t (y, z, npts) + } + call icg_uaxes$t (axistype, cv, x, y, z, npts, Memc[label], + Memc[units], SZ_LINE) + call gt_sets (gt, gtlabel[axis], Memc[label]) + call gt_sets (gt, gtunits[axis], Memc[units]) + call mfree (label, TY_CHAR) + call mfree (units, TY_CHAR) + } +end + + +# ICG_DVZ -- Error action to take on zero division. + +PIXEL procedure icg_dvz$t (x) + +PIXEL x # Numerator + +begin + return (1.) +end diff --git a/pkg/xtools/icfit/icgaxesd.x b/pkg/xtools/icfit/icgaxesd.x new file mode 100644 index 00000000..9505c4c8 --- /dev/null +++ b/pkg/xtools/icfit/icgaxesd.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/gtools.h> +include "icfit.h" +include "names.h" + +# ICG_AXES -- Set axes data. +# The applications program may set additional axes types. + +procedure icg_axesd (ic, gt, cv, axis, x, y, z, npts) + +pointer ic # ICFIT pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +int axis # Output axis +double x[npts] # Independent variable +double y[npts] # Dependent variable +double z[npts] # Output values +int npts # Number of points + +int i, axistype, gtlabel[2], gtunits[2] +double a, b, xmin, xmax +pointer label, units + +double dcveval(), icg_dvzd() +errchk adivd() +extern icg_dvzd() + +data gtlabel/GTXLABEL, GTYLABEL/ +data gtunits/GTXUNITS, GTYUNITS/ + +begin + axistype = IC_AXES(ic, IC_GKEY(ic), axis) + switch (axistype) { + case 'x': # Independent variable + call gt_sets (gt, gtlabel[axis], Memc[IC_LABELS(ic,1)]) + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,1)]) + call amovd (x, z, npts) + case 'y': # Dependent variable + call gt_sets (gt, gtlabel[axis], Memc[IC_LABELS(ic,2)]) + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + call amovd (y, z, npts) + case 'f': # Fitted values + call gt_sets (gt, gtlabel[axis], "fit") + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + call dcvvector (cv, x, z, npts) + case 'r': # Residuals + call gt_sets (gt, gtlabel[axis], "residuals") + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + call dcvvector (cv, x, z, npts) + call asubd (y, z, z, npts) + case 'd': # Ratio + call gt_sets (gt, gtlabel[axis], "ratio") + call gt_sets (gt, gtunits[axis], "") + call dcvvector (cv, x, z, npts) +# iferr (call adiv$t (y, z, z, npts)) + call advzd (y, z, z, npts, icg_dvzd) + case 'n': # Linear component removed + call gt_sets (gt, gtlabel[axis], "non-linear component") + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + xmin = IC_XMIN(ic) + xmax = IC_XMAX(ic) + a = dcveval (cv, double (xmin)) + b = (dcveval (cv, double (xmax)) - a) / (xmax - xmin) + do i = 1, npts + z[i] = y[i] - a - b * (x[i] - xmin) + case 'v': + call gt_sets (gt, gtlabel[axis], "Velocity") + call gt_sets (gt, gtunits[axis], "km/s") + call dcvvector (cv, x, z, npts) + do i = 1, npts + z[i] = (z[i] - y[i]) / y[i] * 300000. + default: # User axes types. + call malloc (label, SZ_LINE, TY_CHAR) + call malloc (units, SZ_LINE, TY_CHAR) + if (axis == 1) { + call strcpy (Memc[IC_LABELS(ic,1)], Memc[label], SZ_LINE) + call strcpy (Memc[IC_UNITS(ic,1)], Memc[units], SZ_LINE) + call amovd (x, z, npts) + } else { + call strcpy (Memc[IC_LABELS(ic,2)], Memc[label], SZ_LINE) + call strcpy (Memc[IC_UNITS(ic,2)], Memc[units], SZ_LINE) + call amovd (y, z, npts) + } + call icg_uaxesd (axistype, cv, x, y, z, npts, Memc[label], + Memc[units], SZ_LINE) + call gt_sets (gt, gtlabel[axis], Memc[label]) + call gt_sets (gt, gtunits[axis], Memc[units]) + call mfree (label, TY_CHAR) + call mfree (units, TY_CHAR) + } +end + + +# ICG_DVZ -- Error action to take on zero division. + +double procedure icg_dvzd (x) + +double x # Numerator + +begin + return (1.) +end diff --git a/pkg/xtools/icfit/icgaxesr.x b/pkg/xtools/icfit/icgaxesr.x new file mode 100644 index 00000000..dcd4d686 --- /dev/null +++ b/pkg/xtools/icfit/icgaxesr.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/gtools.h> +include "icfit.h" +include "names.h" + +# ICG_AXES -- Set axes data. +# The applications program may set additional axes types. + +procedure icg_axesr (ic, gt, cv, axis, x, y, z, npts) + +pointer ic # ICFIT pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +int axis # Output axis +real x[npts] # Independent variable +real y[npts] # Dependent variable +real z[npts] # Output values +int npts # Number of points + +int i, axistype, gtlabel[2], gtunits[2] +real a, b, xmin, xmax +pointer label, units + +real rcveval(), icg_dvzr() +errchk adivr() +extern icg_dvzr() + +data gtlabel/GTXLABEL, GTYLABEL/ +data gtunits/GTXUNITS, GTYUNITS/ + +begin + axistype = IC_AXES(ic, IC_GKEY(ic), axis) + switch (axistype) { + case 'x': # Independent variable + call gt_sets (gt, gtlabel[axis], Memc[IC_LABELS(ic,1)]) + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,1)]) + call amovr (x, z, npts) + case 'y': # Dependent variable + call gt_sets (gt, gtlabel[axis], Memc[IC_LABELS(ic,2)]) + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + call amovr (y, z, npts) + case 'f': # Fitted values + call gt_sets (gt, gtlabel[axis], "fit") + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + call rcvvector (cv, x, z, npts) + case 'r': # Residuals + call gt_sets (gt, gtlabel[axis], "residuals") + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + call rcvvector (cv, x, z, npts) + call asubr (y, z, z, npts) + case 'd': # Ratio + call gt_sets (gt, gtlabel[axis], "ratio") + call gt_sets (gt, gtunits[axis], "") + call rcvvector (cv, x, z, npts) +# iferr (call adiv$t (y, z, z, npts)) + call advzr (y, z, z, npts, icg_dvzr) + case 'n': # Linear component removed + call gt_sets (gt, gtlabel[axis], "non-linear component") + call gt_sets (gt, gtunits[axis], Memc[IC_UNITS(ic,2)]) + xmin = IC_XMIN(ic) + xmax = IC_XMAX(ic) + a = rcveval (cv, real (xmin)) + b = (rcveval (cv, real (xmax)) - a) / (xmax - xmin) + do i = 1, npts + z[i] = y[i] - a - b * (x[i] - xmin) + case 'v': + call gt_sets (gt, gtlabel[axis], "Velocity") + call gt_sets (gt, gtunits[axis], "km/s") + call rcvvector (cv, x, z, npts) + do i = 1, npts + z[i] = (z[i] - y[i]) / y[i] * 300000. + default: # User axes types. + call malloc (label, SZ_LINE, TY_CHAR) + call malloc (units, SZ_LINE, TY_CHAR) + if (axis == 1) { + call strcpy (Memc[IC_LABELS(ic,1)], Memc[label], SZ_LINE) + call strcpy (Memc[IC_UNITS(ic,1)], Memc[units], SZ_LINE) + call amovr (x, z, npts) + } else { + call strcpy (Memc[IC_LABELS(ic,2)], Memc[label], SZ_LINE) + call strcpy (Memc[IC_UNITS(ic,2)], Memc[units], SZ_LINE) + call amovr (y, z, npts) + } + call icg_uaxesr (axistype, cv, x, y, z, npts, Memc[label], + Memc[units], SZ_LINE) + call gt_sets (gt, gtlabel[axis], Memc[label]) + call gt_sets (gt, gtunits[axis], Memc[units]) + call mfree (label, TY_CHAR) + call mfree (units, TY_CHAR) + } +end + + +# ICG_DVZ -- Error action to take on zero division. + +real procedure icg_dvzr (x) + +real x # Numerator + +begin + return (1.) +end diff --git a/pkg/xtools/icfit/icgcolon.gx b/pkg/xtools/icfit/icgcolon.gx new file mode 100644 index 00000000..14329164 --- /dev/null +++ b/pkg/xtools/icfit/icgcolon.gx @@ -0,0 +1,218 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <pkg/gtools.h> +include "icfit.h" +include "names.h" + +# List of colon commands. +define CMDS "|function|order|sample|naverage|niterate|low_reject|high_reject\ + |grow|markrej|color|show|vshow|xyshow|errors|evaluate\ + |graph|help|gui|" + +define FUNCTION 1 # Set or show function type +define ORDER 2 # Set or show function order +define SAMPLE 3 # Set or show sample ranges +define NAVERAGE 4 # Set or show sample averaging or medianing +define NITERATE 5 # Set or show rejection iterations +define LOW_REJECT 6 # Set or show lower rejection factor +define HIGH_REJECT 7 # Set or show upper rejection factor +define GROW 8 # Set or show rejection growing radius +define MARKREJ 9 # Mark rejected points +define COLOR 10 # Fit color +define SHOW 11 # Show values of parameters +define VSHOW 12 # Show verbose information +define XYSHOW 13 # Show x-y-fit-wts values +define ERRORS 14 # Show errors of fit +define EVALUATE 15 # Evaluate fit at specified value +define GRAPH 16 # Define graph +define HELP 17 # Set help file +define GUI 18 # Send GUI command + +# ICG_COLON -- Processes colon commands. The common flags and newgraph +# signal changes in fitting parameters or the need to redraw the graph. + +procedure icg_colon$t (ic, cmdstr, newgraph, gp, gt, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +char cmdstr[ARB] # Command string +int newgraph # New graph? +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer for error listing +PIXEL x[npts], y[npts], wts[npts] # Data arrays for error listing +int npts # Number of data points + +PIXEL val, $tcveval() +char key, xtype, ytype +bool bval +int ncmd, ival +real rval +pointer sp, cmd + +int nscan(), strdic(), btoi() + +string funcs "|chebyshev|legendre|spline1|spline3|power|" + +begin + # Check for GTOOLS command. + if (cmdstr[1] == '/') { + call gt_colon (cmdstr, gp, gt, newgraph) + return + } + + # Use formated scan to parse the command string. + # The first word is the command and it may be minimum match + # abbreviated with the list of commands. + + call smark (sp) + call salloc (cmd, IC_SZSAMPLE, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], IC_SZSAMPLE) + ncmd = strdic (Memc[cmd], Memc[cmd], IC_SZSAMPLE, CMDS) + + switch (ncmd) { + case FUNCTION: # :function - List or set the fitting function. + call gargwrd (Memc[cmd], IC_SZSAMPLE) + if (nscan() == 1) { + call printf ("function = %s\n") + call ic_gstr (ic, "function", Memc[cmd], IC_SZSAMPLE) + call pargstr (Memc[cmd]) + } else { + if (strdic (Memc[cmd], Memc[cmd], IC_SZSAMPLE, funcs) > 0) { + call ic_pstr (ic, "function", Memc[cmd]) + IC_NEWFUNCTION(ic) = YES + } else + call printf ("Unknown or ambiguous function\n") + } + + case ORDER: # :order - List or set the function order. + call gargi (ival) + if (nscan() == 1) { + call printf ("order = %d\n") + call pargi (IC_ORDER(ic)) + } else if (ival < 1) { + call printf ("Order must be greater than zero\n") + } else { + call ic_puti (ic, "order", ival) + IC_NEWFUNCTION(ic) = YES + } + + case SAMPLE: # :sample - List or set the sample points. + call gargstr (Memc[cmd], IC_SZSAMPLE) + if (Memc[cmd] == EOS) { + call printf ("sample = %s\n") + call pargstr (Memc[IC_SAMPLE(ic)]) + } else { + call ic_pstr (ic, "sample", Memc[cmd]) + IC_NEWX(ic) = YES + } + + case NAVERAGE: # :naverage - List or set the sample averging. + call gargi (ival) + if (nscan() == 1) { + call printf ("naverage = %d\n") + call pargi (IC_NAVERAGE(ic)) + } else { + call ic_puti (ic, "naverage", ival) + IC_NEWX(ic) = YES + } + + case NITERATE: # :niterate - List or set the rejection iterations. + call gargi (ival) + if (nscan() == 1) { + call printf ("niterate = %d\n") + call pargi (IC_NITERATE(ic)) + } else + call ic_puti (ic, "niterate", ival) + + + case LOW_REJECT: # :low_reject - List or set lower rejection factor. + call gargr (rval) + if (nscan() == 1) { + call printf ("low_reject = %g\n") + call pargr (IC_LOW(ic)) + } else + call ic_putr (ic, "low", rval) + + case HIGH_REJECT: # :high_reject - List or set high rejection factor. + call gargr (rval) + if (nscan() == 1) { + call printf ("high_reject = %g\n") + call pargr (IC_HIGH(ic)) + } else + call ic_putr (ic, "high", rval) + + case GROW: # :grow - List or set the rejection growing. + call gargr (rval) + if (nscan() == 1) { + call printf ("grow = %g\n") + call pargr (IC_GROW(ic)) + } else + call ic_putr (ic, "grow", rval) + + case MARKREJ: # :markrej - Mark rejected points + call gargb (bval) + if (nscan() == 1) { + call printf ("markrej = %b\n") + call pargi (IC_MARKREJ(ic)) + } else + call ic_puti (ic, "markrej", btoi (bval)) + + case COLOR: # :color - List or set the fit color. + call gargi (ival) + if (nscan() == 1) { + call printf ("color = %d\n") + call pargi (IC_COLOR(ic)) + } else + call ic_puti (ic, "color", ival) + + case SHOW, VSHOW, XYSHOW, ERRORS: + call ic_guishow$t (ic, cmdstr, cv, x, y, wts, npts) + + case EVALUATE: # :evaluate x - evaluate fit at x. + call garg$t (val) + if (nscan() == 1) + call printf ("evaluate requires a value to evaluate\n") + else { + call printf ("fit(%g) = %g\n") + call parg$t (val) + call parg$t ($tcveval (cv, val)) + } + + case GRAPH: # :graph key xtype ytpe + call gargc (key) + call gargc (xtype) + call gargc (ytype) + if (nscan() != 4) { + ival = IC_GKEY(ic) + call printf ("graph %c %c %c\n") + call pargi ('h'+ival-1) + call pargi (IC_AXES(ic,ival,1)) + call pargi (IC_AXES(ic,ival,2)) + } else { + ival = key - 'h' + 1 + IC_GKEY(ic) = ival + call ic_pkey (ic, ival, int(xtype), int(ytype)) + newgraph = YES + } + + case HELP: # :help file + call gargwrd (Memc[cmd], IC_SZSAMPLE) + if (Memc[cmd] == EOS) { + call printf ("help = %s\n") + call pargstr (Memc[IC_HELP(ic)]) + } else + call ic_pstr (ic, "help", Memc[cmd]) + + case GUI: # :gui command - Update, unlearn or set the options. + call gargstr (Memc[cmd], IC_SZSAMPLE) + call ic_gui (ic, Memc[cmd]) + + default: # Unrecognized command. + call printf ("Unrecognized command or ambiguous abbreviation\007") + } + + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgcolond.x b/pkg/xtools/icfit/icgcolond.x new file mode 100644 index 00000000..00c92a0d --- /dev/null +++ b/pkg/xtools/icfit/icgcolond.x @@ -0,0 +1,218 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <pkg/gtools.h> +include "icfit.h" +include "names.h" + +# List of colon commands. +define CMDS "|function|order|sample|naverage|niterate|low_reject|high_reject\ + |grow|markrej|color|show|vshow|xyshow|errors|evaluate\ + |graph|help|gui|" + +define FUNCTION 1 # Set or show function type +define ORDER 2 # Set or show function order +define SAMPLE 3 # Set or show sample ranges +define NAVERAGE 4 # Set or show sample averaging or medianing +define NITERATE 5 # Set or show rejection iterations +define LOW_REJECT 6 # Set or show lower rejection factor +define HIGH_REJECT 7 # Set or show upper rejection factor +define GROW 8 # Set or show rejection growing radius +define MARKREJ 9 # Mark rejected points +define COLOR 10 # Fit color +define SHOW 11 # Show values of parameters +define VSHOW 12 # Show verbose information +define XYSHOW 13 # Show x-y-fit-wts values +define ERRORS 14 # Show errors of fit +define EVALUATE 15 # Evaluate fit at specified value +define GRAPH 16 # Define graph +define HELP 17 # Set help file +define GUI 18 # Send GUI command + +# ICG_COLON -- Processes colon commands. The common flags and newgraph +# signal changes in fitting parameters or the need to redraw the graph. + +procedure icg_colond (ic, cmdstr, newgraph, gp, gt, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +char cmdstr[ARB] # Command string +int newgraph # New graph? +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer for error listing +double x[npts], y[npts], wts[npts] # Data arrays for error listing +int npts # Number of data points + +double val, dcveval() +char key, xtype, ytype +bool bval +int ncmd, ival +real rval +pointer sp, cmd + +int nscan(), strdic(), btoi() + +string funcs "|chebyshev|legendre|spline1|spline3|power|" + +begin + # Check for GTOOLS command. + if (cmdstr[1] == '/') { + call gt_colon (cmdstr, gp, gt, newgraph) + return + } + + # Use formated scan to parse the command string. + # The first word is the command and it may be minimum match + # abbreviated with the list of commands. + + call smark (sp) + call salloc (cmd, IC_SZSAMPLE, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], IC_SZSAMPLE) + ncmd = strdic (Memc[cmd], Memc[cmd], IC_SZSAMPLE, CMDS) + + switch (ncmd) { + case FUNCTION: # :function - List or set the fitting function. + call gargwrd (Memc[cmd], IC_SZSAMPLE) + if (nscan() == 1) { + call printf ("function = %s\n") + call ic_gstr (ic, "function", Memc[cmd], IC_SZSAMPLE) + call pargstr (Memc[cmd]) + } else { + if (strdic (Memc[cmd], Memc[cmd], IC_SZSAMPLE, funcs) > 0) { + call ic_pstr (ic, "function", Memc[cmd]) + IC_NEWFUNCTION(ic) = YES + } else + call printf ("Unknown or ambiguous function\n") + } + + case ORDER: # :order - List or set the function order. + call gargi (ival) + if (nscan() == 1) { + call printf ("order = %d\n") + call pargi (IC_ORDER(ic)) + } else if (ival < 1) { + call printf ("Order must be greater than zero\n") + } else { + call ic_puti (ic, "order", ival) + IC_NEWFUNCTION(ic) = YES + } + + case SAMPLE: # :sample - List or set the sample points. + call gargstr (Memc[cmd], IC_SZSAMPLE) + if (Memc[cmd] == EOS) { + call printf ("sample = %s\n") + call pargstr (Memc[IC_SAMPLE(ic)]) + } else { + call ic_pstr (ic, "sample", Memc[cmd]) + IC_NEWX(ic) = YES + } + + case NAVERAGE: # :naverage - List or set the sample averging. + call gargi (ival) + if (nscan() == 1) { + call printf ("naverage = %d\n") + call pargi (IC_NAVERAGE(ic)) + } else { + call ic_puti (ic, "naverage", ival) + IC_NEWX(ic) = YES + } + + case NITERATE: # :niterate - List or set the rejection iterations. + call gargi (ival) + if (nscan() == 1) { + call printf ("niterate = %d\n") + call pargi (IC_NITERATE(ic)) + } else + call ic_puti (ic, "niterate", ival) + + + case LOW_REJECT: # :low_reject - List or set lower rejection factor. + call gargr (rval) + if (nscan() == 1) { + call printf ("low_reject = %g\n") + call pargr (IC_LOW(ic)) + } else + call ic_putr (ic, "low", rval) + + case HIGH_REJECT: # :high_reject - List or set high rejection factor. + call gargr (rval) + if (nscan() == 1) { + call printf ("high_reject = %g\n") + call pargr (IC_HIGH(ic)) + } else + call ic_putr (ic, "high", rval) + + case GROW: # :grow - List or set the rejection growing. + call gargr (rval) + if (nscan() == 1) { + call printf ("grow = %g\n") + call pargr (IC_GROW(ic)) + } else + call ic_putr (ic, "grow", rval) + + case MARKREJ: # :markrej - Mark rejected points + call gargb (bval) + if (nscan() == 1) { + call printf ("markrej = %b\n") + call pargi (IC_MARKREJ(ic)) + } else + call ic_puti (ic, "markrej", btoi (bval)) + + case COLOR: # :color - List or set the fit color. + call gargi (ival) + if (nscan() == 1) { + call printf ("color = %d\n") + call pargi (IC_COLOR(ic)) + } else + call ic_puti (ic, "color", ival) + + case SHOW, VSHOW, XYSHOW, ERRORS: + call ic_guishowd (ic, cmdstr, cv, x, y, wts, npts) + + case EVALUATE: # :evaluate x - evaluate fit at x. + call gargd (val) + if (nscan() == 1) + call printf ("evaluate requires a value to evaluate\n") + else { + call printf ("fit(%g) = %g\n") + call pargd (val) + call pargd (dcveval (cv, val)) + } + + case GRAPH: # :graph key xtype ytpe + call gargc (key) + call gargc (xtype) + call gargc (ytype) + if (nscan() != 4) { + ival = IC_GKEY(ic) + call printf ("graph %c %c %c\n") + call pargi ('h'+ival-1) + call pargi (IC_AXES(ic,ival,1)) + call pargi (IC_AXES(ic,ival,2)) + } else { + ival = key - 'h' + 1 + IC_GKEY(ic) = ival + call ic_pkey (ic, ival, int(xtype), int(ytype)) + newgraph = YES + } + + case HELP: # :help file + call gargwrd (Memc[cmd], IC_SZSAMPLE) + if (Memc[cmd] == EOS) { + call printf ("help = %s\n") + call pargstr (Memc[IC_HELP(ic)]) + } else + call ic_pstr (ic, "help", Memc[cmd]) + + case GUI: # :gui command - Update, unlearn or set the options. + call gargstr (Memc[cmd], IC_SZSAMPLE) + call ic_gui (ic, Memc[cmd]) + + default: # Unrecognized command. + call printf ("Unrecognized command or ambiguous abbreviation\007") + } + + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgcolonr.x b/pkg/xtools/icfit/icgcolonr.x new file mode 100644 index 00000000..dc320c2b --- /dev/null +++ b/pkg/xtools/icfit/icgcolonr.x @@ -0,0 +1,218 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <pkg/gtools.h> +include "icfit.h" +include "names.h" + +# List of colon commands. +define CMDS "|function|order|sample|naverage|niterate|low_reject|high_reject\ + |grow|markrej|color|show|vshow|xyshow|errors|evaluate\ + |graph|help|gui|" + +define FUNCTION 1 # Set or show function type +define ORDER 2 # Set or show function order +define SAMPLE 3 # Set or show sample ranges +define NAVERAGE 4 # Set or show sample averaging or medianing +define NITERATE 5 # Set or show rejection iterations +define LOW_REJECT 6 # Set or show lower rejection factor +define HIGH_REJECT 7 # Set or show upper rejection factor +define GROW 8 # Set or show rejection growing radius +define MARKREJ 9 # Mark rejected points +define COLOR 10 # Fit color +define SHOW 11 # Show values of parameters +define VSHOW 12 # Show verbose information +define XYSHOW 13 # Show x-y-fit-wts values +define ERRORS 14 # Show errors of fit +define EVALUATE 15 # Evaluate fit at specified value +define GRAPH 16 # Define graph +define HELP 17 # Set help file +define GUI 18 # Send GUI command + +# ICG_COLON -- Processes colon commands. The common flags and newgraph +# signal changes in fitting parameters or the need to redraw the graph. + +procedure icg_colonr (ic, cmdstr, newgraph, gp, gt, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +char cmdstr[ARB] # Command string +int newgraph # New graph? +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer for error listing +real x[npts], y[npts], wts[npts] # Data arrays for error listing +int npts # Number of data points + +real val, rcveval() +char key, xtype, ytype +bool bval +int ncmd, ival +real rval +pointer sp, cmd + +int nscan(), strdic(), btoi() + +string funcs "|chebyshev|legendre|spline1|spline3|power|" + +begin + # Check for GTOOLS command. + if (cmdstr[1] == '/') { + call gt_colon (cmdstr, gp, gt, newgraph) + return + } + + # Use formated scan to parse the command string. + # The first word is the command and it may be minimum match + # abbreviated with the list of commands. + + call smark (sp) + call salloc (cmd, IC_SZSAMPLE, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], IC_SZSAMPLE) + ncmd = strdic (Memc[cmd], Memc[cmd], IC_SZSAMPLE, CMDS) + + switch (ncmd) { + case FUNCTION: # :function - List or set the fitting function. + call gargwrd (Memc[cmd], IC_SZSAMPLE) + if (nscan() == 1) { + call printf ("function = %s\n") + call ic_gstr (ic, "function", Memc[cmd], IC_SZSAMPLE) + call pargstr (Memc[cmd]) + } else { + if (strdic (Memc[cmd], Memc[cmd], IC_SZSAMPLE, funcs) > 0) { + call ic_pstr (ic, "function", Memc[cmd]) + IC_NEWFUNCTION(ic) = YES + } else + call printf ("Unknown or ambiguous function\n") + } + + case ORDER: # :order - List or set the function order. + call gargi (ival) + if (nscan() == 1) { + call printf ("order = %d\n") + call pargi (IC_ORDER(ic)) + } else if (ival < 1) { + call printf ("Order must be greater than zero\n") + } else { + call ic_puti (ic, "order", ival) + IC_NEWFUNCTION(ic) = YES + } + + case SAMPLE: # :sample - List or set the sample points. + call gargstr (Memc[cmd], IC_SZSAMPLE) + if (Memc[cmd] == EOS) { + call printf ("sample = %s\n") + call pargstr (Memc[IC_SAMPLE(ic)]) + } else { + call ic_pstr (ic, "sample", Memc[cmd]) + IC_NEWX(ic) = YES + } + + case NAVERAGE: # :naverage - List or set the sample averging. + call gargi (ival) + if (nscan() == 1) { + call printf ("naverage = %d\n") + call pargi (IC_NAVERAGE(ic)) + } else { + call ic_puti (ic, "naverage", ival) + IC_NEWX(ic) = YES + } + + case NITERATE: # :niterate - List or set the rejection iterations. + call gargi (ival) + if (nscan() == 1) { + call printf ("niterate = %d\n") + call pargi (IC_NITERATE(ic)) + } else + call ic_puti (ic, "niterate", ival) + + + case LOW_REJECT: # :low_reject - List or set lower rejection factor. + call gargr (rval) + if (nscan() == 1) { + call printf ("low_reject = %g\n") + call pargr (IC_LOW(ic)) + } else + call ic_putr (ic, "low", rval) + + case HIGH_REJECT: # :high_reject - List or set high rejection factor. + call gargr (rval) + if (nscan() == 1) { + call printf ("high_reject = %g\n") + call pargr (IC_HIGH(ic)) + } else + call ic_putr (ic, "high", rval) + + case GROW: # :grow - List or set the rejection growing. + call gargr (rval) + if (nscan() == 1) { + call printf ("grow = %g\n") + call pargr (IC_GROW(ic)) + } else + call ic_putr (ic, "grow", rval) + + case MARKREJ: # :markrej - Mark rejected points + call gargb (bval) + if (nscan() == 1) { + call printf ("markrej = %b\n") + call pargi (IC_MARKREJ(ic)) + } else + call ic_puti (ic, "markrej", btoi (bval)) + + case COLOR: # :color - List or set the fit color. + call gargi (ival) + if (nscan() == 1) { + call printf ("color = %d\n") + call pargi (IC_COLOR(ic)) + } else + call ic_puti (ic, "color", ival) + + case SHOW, VSHOW, XYSHOW, ERRORS: + call ic_guishowr (ic, cmdstr, cv, x, y, wts, npts) + + case EVALUATE: # :evaluate x - evaluate fit at x. + call gargr (val) + if (nscan() == 1) + call printf ("evaluate requires a value to evaluate\n") + else { + call printf ("fit(%g) = %g\n") + call pargr (val) + call pargr (rcveval (cv, val)) + } + + case GRAPH: # :graph key xtype ytpe + call gargc (key) + call gargc (xtype) + call gargc (ytype) + if (nscan() != 4) { + ival = IC_GKEY(ic) + call printf ("graph %c %c %c\n") + call pargi ('h'+ival-1) + call pargi (IC_AXES(ic,ival,1)) + call pargi (IC_AXES(ic,ival,2)) + } else { + ival = key - 'h' + 1 + IC_GKEY(ic) = ival + call ic_pkey (ic, ival, int(xtype), int(ytype)) + newgraph = YES + } + + case HELP: # :help file + call gargwrd (Memc[cmd], IC_SZSAMPLE) + if (Memc[cmd] == EOS) { + call printf ("help = %s\n") + call pargstr (Memc[IC_HELP(ic)]) + } else + call ic_pstr (ic, "help", Memc[cmd]) + + case GUI: # :gui command - Update, unlearn or set the options. + call gargstr (Memc[cmd], IC_SZSAMPLE) + call ic_gui (ic, Memc[cmd]) + + default: # Unrecognized command. + call printf ("Unrecognized command or ambiguous abbreviation\007") + } + + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgdelete.gx b/pkg/xtools/icfit/icgdelete.gx new file mode 100644 index 00000000..1c2a6fd6 --- /dev/null +++ b/pkg/xtools/icfit/icgdelete.gx @@ -0,0 +1,89 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <mach.h> +include <pkg/gtools.h> +include "icfit.h" + +define MSIZE 2. # Mark size + +# ICG_DELETE -- Delete data point nearest the cursor. +# The nearest point to the cursor in NDC coordinates is determined. + +procedure icg_delete$t (ic, gp, gt, cv, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +PIXEL x[npts], y[npts] # Data points +PIXEL wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int gt_geti() +pointer sp, xout, yout + +begin + call smark (sp) + call salloc (xout, npts, TY_PIXEL) + call salloc (yout, npts, TY_PIXEL) + + call icg_axes$t (ic, gt, cv, 1, x, y, Mem$t[xout], npts) + call icg_axes$t (ic, gt, cv, 2, x, y, Mem$t[yout], npts) + + if (gt_geti (gt, GTTRANSPOSE) == NO) + call icg_d1$t (ic, gp, Mem$t[xout], Mem$t[yout], wts, userwts, + npts, wx, wy) + else + call icg_d1$t (ic, gp, Mem$t[yout], Mem$t[xout], wts, userwts, + npts, wy, wx) + + call sfree (sp) +end + + +# ICG_D1 -- Do the actual delete. + +procedure icg_d1$t (ic, gp, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +PIXEL x[npts], y[npts] # Data points +PIXEL wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with non-zero weight. + + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] == 0.) + next + + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark the deleted point with a cross and set the weight to zero. + + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + wts[j] = 0. + IC_NEWWTS(ic) = YES + } +end diff --git a/pkg/xtools/icfit/icgdeleted.x b/pkg/xtools/icfit/icgdeleted.x new file mode 100644 index 00000000..60027998 --- /dev/null +++ b/pkg/xtools/icfit/icgdeleted.x @@ -0,0 +1,89 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <mach.h> +include <pkg/gtools.h> +include "icfit.h" + +define MSIZE 2. # Mark size + +# ICG_DELETE -- Delete data point nearest the cursor. +# The nearest point to the cursor in NDC coordinates is determined. + +procedure icg_deleted (ic, gp, gt, cv, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +double x[npts], y[npts] # Data points +double wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int gt_geti() +pointer sp, xout, yout + +begin + call smark (sp) + call salloc (xout, npts, TY_DOUBLE) + call salloc (yout, npts, TY_DOUBLE) + + call icg_axesd (ic, gt, cv, 1, x, y, Memd[xout], npts) + call icg_axesd (ic, gt, cv, 2, x, y, Memd[yout], npts) + + if (gt_geti (gt, GTTRANSPOSE) == NO) + call icg_d1d (ic, gp, Memd[xout], Memd[yout], wts, userwts, + npts, wx, wy) + else + call icg_d1d (ic, gp, Memd[yout], Memd[xout], wts, userwts, + npts, wy, wx) + + call sfree (sp) +end + + +# ICG_D1 -- Do the actual delete. + +procedure icg_d1d (ic, gp, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +double x[npts], y[npts] # Data points +double wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with non-zero weight. + + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] == 0.) + next + + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark the deleted point with a cross and set the weight to zero. + + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + wts[j] = 0. + IC_NEWWTS(ic) = YES + } +end diff --git a/pkg/xtools/icfit/icgdeleter.x b/pkg/xtools/icfit/icgdeleter.x new file mode 100644 index 00000000..86edd93b --- /dev/null +++ b/pkg/xtools/icfit/icgdeleter.x @@ -0,0 +1,89 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <mach.h> +include <pkg/gtools.h> +include "icfit.h" + +define MSIZE 2. # Mark size + +# ICG_DELETE -- Delete data point nearest the cursor. +# The nearest point to the cursor in NDC coordinates is determined. + +procedure icg_deleter (ic, gp, gt, cv, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +real x[npts], y[npts] # Data points +real wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int gt_geti() +pointer sp, xout, yout + +begin + call smark (sp) + call salloc (xout, npts, TY_REAL) + call salloc (yout, npts, TY_REAL) + + call icg_axesr (ic, gt, cv, 1, x, y, Memr[xout], npts) + call icg_axesr (ic, gt, cv, 2, x, y, Memr[yout], npts) + + if (gt_geti (gt, GTTRANSPOSE) == NO) + call icg_d1r (ic, gp, Memr[xout], Memr[yout], wts, userwts, + npts, wx, wy) + else + call icg_d1r (ic, gp, Memr[yout], Memr[xout], wts, userwts, + npts, wy, wx) + + call sfree (sp) +end + + +# ICG_D1 -- Do the actual delete. + +procedure icg_d1r (ic, gp, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +real x[npts], y[npts] # Data points +real wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with non-zero weight. + + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] == 0.) + next + + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark the deleted point with a cross and set the weight to zero. + + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + wts[j] = 0. + IC_NEWWTS(ic) = YES + } +end diff --git a/pkg/xtools/icfit/icgfit.gx b/pkg/xtools/icfit/icgfit.gx new file mode 100644 index 00000000..767daa3e --- /dev/null +++ b/pkg/xtools/icfit/icgfit.gx @@ -0,0 +1,544 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <pkg/gtools.h> +include "names.h" +include "icfit.h" + +# ICG_FIT -- Interactive curve fitting with graphics. This is the main +# entry point for the interactive graphics part of the icfit package. + +procedure icg_fit$t (ic, gp, cursor, gt, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +char cursor[ARB] # GIO cursor input +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +PIXEL x[npts] # Ordinates +PIXEL y[npts] # Abscissas +PIXEL wts[npts] # Weights +int npts # Number of points + +real wx, wy +int wcs, key + +int i, j, newgraph, axes[2], xtype +PIXEL px1 +real rx1, rx2, ry1, ry2 +pointer sp, cmd, userwts, x1, y1, w1, n + +int gt_gcur1(), stridxs(), scan(), nscan() +int icg_nearest$t() +PIXEL $tcveval() +errchk ic_fit$t() + +begin + call smark (sp) + call salloc (cmd, IC_SZSAMPLE, TY_CHAR) + + # Allocate memory for the fit and a copy of the weights. + # The weights are copied because they are changed when points are + # deleted. + + n = npts + x1 = NULL + y1 = NULL + w1 = NULL + call malloc (userwts, n, TY_PIXEL) + call amov$t (wts, Mem$t[userwts], n) + + # Initialize + IC_GP(ic) = gp + IC_GT(ic) = gt + IC_OVERPLOT(ic) = NO + IC_NEWX(ic) = YES + IC_NEWY(ic) = YES + IC_NEWWTS(ic) = YES + IC_NEWFUNCTION(ic) = YES + + # Send the GUI the current task values. + call ic_gui (ic, "open") + call ic_gui (ic, "graph") + + # Read cursor commands. + + key = 'f' + newgraph = YES + axes[1] = IC_AXES(ic, IC_GKEY(ic), 1) + axes[2] = IC_AXES(ic, IC_GKEY(ic), 2) + xtype = 0 + + repeat { + switch (key) { + case '?': # Print help text. + call ic_gui (ic, "help") + + case ':': # List or set parameters + if (Memc[cmd] == '/') + call gt_colon (Memc[cmd], gp, gt, newgraph) + else + call icg_colon$t (ic, Memc[cmd], newgraph, gp, gt, cv, + x, y, wts, n) + + case 'a': # Add points + if ((IC_AXES(ic,IC_GKEY(ic),1) == 'x') && + (IC_AXES(ic,IC_GKEY(ic),2) == 'y')) + ; + else if ((IC_AXES(ic,IC_GKEY(ic),1) == 'y') && + (IC_AXES(ic,IC_GKEY(ic),2) == 'x')) { + rx1 = wx + wx = wy + wy = rx1 + } else { + call printf ("Graph must be x vs. y or y vs. x\07\n") + next + } + + rx1 = 1. + call printf ("weight = (%g) ") + call pargr (rx1) + call flush (STDOUT) + if (scan() != EOF) { + call gargr (rx2) + if (nscan() == 1) + if (!IS_INDEFR (rx2)) + rx1 = rx2 + } + + if (x1 == NULL) { + call malloc (x1, n+1, TY_PIXEL) + call malloc (y1, n+1, TY_PIXEL) + call malloc (w1, n+1, TY_PIXEL) + call amov$t (x, Mem$t[x1], n) + call amov$t (y, Mem$t[y1], n) + call amov$t (wts, Mem$t[w1], n) + } else { + call realloc (x1, n+1, TY_PIXEL) + call realloc (y1, n+1, TY_PIXEL) + call realloc (w1, n+1, TY_PIXEL) + } + call realloc (userwts, n+1, TY_PIXEL) + + call icg_add$t (gp, wx, wy, rx1, Mem$t[x1], Mem$t[y1], + Mem$t[w1], Mem$t[userwts], n) + + IC_NEWX(ic) = YES + IC_NEWY(ic) = YES + IC_NEWWTS(ic) = YES + + case 'c': # Print the positions of data points. + if (x1 == NULL) { + i = icg_nearest$t (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("x = %g y = %g fit = %g\n") + call parg$t (x[i]) + call parg$t (y[i]) + call parg$t ($tcveval (cv, x[i])) + } + } else { + i = icg_nearest$t (ic, gp, gt, cv, Mem$t[x1], Mem$t[y1], + n, wx, wy) + + if (i != 0) { + call printf ("x = %g y = %g fit = %g\n") + call parg$t (Mem$t[x1+i-1]) + call parg$t (Mem$t[y1+i-1]) + call parg$t ($tcveval (cv, Mem$t[x1+i-1])) + } + } + + case 'd': # Delete data points. + if (x1 == NULL) + call icg_delete$t (ic, gp, gt, cv, x, y, wts, + Mem$t[userwts], n, wx, wy) + else + call icg_delete$t (ic, gp, gt, cv, Mem$t[x1], Mem$t[y1], + Mem$t[w1], Mem$t[userwts], n, wx, wy) + call ic_gui (ic, "refit YES") + + case 'f': # Fit the function and reset the flags. + iferr { + if (x1 == NULL) + call ic_fit$t (ic, cv, x, y, wts, n, IC_NEWX(ic), + IC_NEWY(ic), IC_NEWWTS(ic), IC_NEWFUNCTION(ic)) + else + call ic_fit$t (ic, cv, Mem$t[x1], Mem$t[y1], Mem$t[w1], + n, IC_NEWX(ic), IC_NEWY(ic), IC_NEWWTS(ic), + IC_NEWFUNCTION(ic)) + + IC_NEWX(ic) = NO + IC_NEWY(ic) = NO + IC_NEWWTS(ic) = NO + IC_NEWFUNCTION(ic) = NO + IC_FITERROR(ic) = NO + newgraph = YES + + call ic_gui (ic, "refit NO") + } then { + IC_FITERROR(ic) = YES + call erract (EA_WARN) + } + + case 'g': # Set graph axes types. + call printf ("Graph key to be defined: ") + call flush (STDOUT) + if (scan() == EOF) + goto 10 + call gargc (Memc[cmd]) + + switch (Memc[cmd]) { + case '\n': + case 'h', 'i', 'j', 'k', 'l': + switch (Memc[cmd]) { + case 'h': + key = 1 + case 'i': + key = 2 + case 'j': + key = 3 + case 'k': + key = 4 + case 'l': + key = 5 + } + + call printf ("Set graph axes types (%c, %c): ") + call pargi (IC_AXES(ic, key, 1)) + call pargi (IC_AXES(ic, key, 2)) + call flush (STDOUT) + if (scan() == EOF) + goto 10 + call gargc (Memc[cmd]) + + switch (Memc[cmd]) { + case '\n': + default: + call gargc (Memc[cmd+1]) + call gargc (Memc[cmd+1]) + if (Memc[cmd+1] != '\n') { + IC_AXES(ic, key, 1) = Memc[cmd] + IC_AXES(ic, key, 2) = Memc[cmd+1] + if (IC_GKEY(ic) == key) + newgraph = YES + } + } + default: + call printf ("Not a graph key\n") + } + + case 'h': + if (IC_GKEY(ic) != 1) { + IC_GKEY(ic) = 1 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'i': + if (IC_GKEY(ic) != 2) { + IC_GKEY(ic) = 2 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'j': + if (IC_GKEY(ic) != 3) { + IC_GKEY(ic) = 3 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'k': + if (IC_GKEY(ic) != 4) { + IC_GKEY(ic) = 4 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'l': + if (IC_GKEY(ic) != 5) { + IC_GKEY(ic) = 5 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 't': # Initialize the sample string and erase from the graph. + if (x1 == NULL) + call icg_sample$t (ic, gp, gt, x, n, 0) + else + call icg_sample$t (ic, gp, gt, Mem$t[x1], n, 0) + call ic_pstr (ic, "sample", "*") + IC_NEWX(ic) = YES + + case 'o': # Set overplot flag + IC_OVERPLOT(ic) = YES + + case 'r': # Redraw the graph + newgraph = YES + + case 's': # Set sample regions with the cursor. + if ((IC_AXES(ic,IC_GKEY(ic),1) == 'x') || + (IC_AXES(ic,IC_GKEY(ic),2) == 'x')) { + if (stridxs ("*", Memc[IC_SAMPLE(ic)]) > 0) + Memc[IC_SAMPLE(ic)] = EOS + + rx1 = wx + ry1 = wy + call printf ("again:\n") + if (gt_gcur1(gt, cursor, wx, wy, wcs, key, Memc[cmd], + IC_SZSAMPLE) == EOF) + break + call printf ("\n") + rx2 = wx + ry2 = wy + + # Determine if the x vector is integer. + if (xtype == 0) { + xtype = TY_INT + if (x1 == NULL) { + do i = 1, n + if (x[i] != int (x[i])) { + xtype = TY_REAL + break + } + } else { + do i = 1, n + if (Mem$t[x1+i-1] != int (Mem$t[x1+i-1])) { + xtype = TY_REAL + break + } + } + } + + if (IC_AXES(ic,IC_GKEY(ic),1) == 'x') { + if (xtype == TY_INT) { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %d:%d") + call pargi (nint (rx1)) + call pargi (nint (rx2)) + } else { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %g:%g") + call pargr (rx1) + call pargr (rx2) + } + } else { + if (xtype == TY_INT) { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %d:%d") + call pargi (nint (ry1)) + call pargi (nint (ry2)) + } else { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %g:%g") + call pargr (ry1) + call pargr (ry2) + } + } + call strcat (Memc[cmd], Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + if (x1 == NULL) + call icg_sample$t (ic, gp, gt, x, n, 1) + else + call icg_sample$t (ic, gp, gt, Mem$t[x1], n, 1) + call ic_pstr (ic, "sample", Memc[IC_SAMPLE(ic)]) + IC_NEWX(ic) = YES + } + + case 'u': # Undelete data points. + if (x1 == NULL) + call icg_undelete$t (ic, gp, gt, cv, x, y, wts, + Mem$t[userwts], n, wx, wy) + else + call icg_undelete$t (ic, gp, gt, cv, Mem$t[x1], Mem$t[y1], + Mem$t[w1], Mem$t[userwts], n, wx, wy) + call ic_gui (ic, "refit YES") + + case 'w': # Window graph + call gt_window (gt, gp, cursor, newgraph) + + case 'v': # Reset the value of the weight. + if (x1 == NULL) { + i = icg_nearest$t (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("weight = (%g) ") + call parg$t (wts[i]) + call flush (STDOUT) + if (scan() != EOF) { + call garg$t (px1) + if (nscan() == 1) { + if (!IS_$INDEF (px1)) { + wts[i] = px1 + call ic_gui (ic, "refit YES") + IC_NEWWTS(ic) = YES + } + } + } + } + } else { + i = icg_nearest$t (ic, gp, gt, cv, Mem$t[x1], Mem$t[y1], n, + wx, wy) + + if (i != 0) { + call printf ("weight = (%g) ") + call parg$t (Mem$t[w1+i-1]) + call flush (STDOUT) + if (scan() != EOF) { + call garg$t (px1) + if (nscan() == 1) { + if (!IS_$INDEF (px1)) { + j = icg_nearest$t (ic, gp, gt, cv, x, y, n, + wx, wy) + if (j != 0) + if (x[j] == Mem$t[x1+i-1] && + y[j] == Mem$t[y1+i-1]) + wts[j] = px1 + Mem$t[w1+i-1] = px1 + call ic_gui (ic, "refit YES") + IC_NEWWTS(ic) = YES + } + } + } + } + } + + case 'x': # Reset the value of the x point. + if (x1 == NULL) { + i = icg_nearest$t (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("x = (%g) ") + call parg$t (x[i]) + call flush (STDOUT) + if (scan() != EOF) { + call garg$t (px1) + if (nscan() == 1) { + if (!IS_$INDEF (px1)) { + x[i] = px1 + call ic_gui (ic, "refit YES") + IC_NEWX(ic) = YES + } + } + } + } + } else { + i = icg_nearest$t (ic, gp, gt, cv, Mem$t[x1], Mem$t[y1], n, + wx, wy) + + if (i != 0) { + call printf ("x = (%g) ") + call parg$t (Mem$t[x1+i-1]) + call flush (STDOUT) + if (scan() != EOF) { + call garg$t (px1) + if (nscan() == 1) { + if (!IS_$INDEF (px1)) { + j = icg_nearest$t (ic, gp, gt, cv, x, y, n, + wx, wy) + if (j != 0) + if (x[j] == Mem$t[x1+i-1] && + y[j] == Mem$t[y1+i-1]) + x[j] = px1 + Mem$t[x1+i-1] = px1 + call ic_gui (ic, "refit YES") + IC_NEWX(ic) = YES + } + } + } + } + } + + case 'y': # Reset the value of the y point. + if (x1 == NULL) { + i = icg_nearest$t (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("y = (%g) ") + call parg$t (y[i]) + call flush (STDOUT) + if (scan() != EOF) { + call garg$t (px1) + if (nscan() == 1) { + if (!IS_$INDEF (px1)) { + y[i] = px1 + call ic_gui (ic, "refit YES") + IC_NEWY(ic) = YES + } + } + } + } + } else { + i = icg_nearest$t (ic, gp, gt, cv, Mem$t[x1], Mem$t[y1], n, + wx, wy) + + if (i != 0) { + call printf ("y = (%g) ") + call parg$t (Mem$t[y1+i-1]) + call flush (STDOUT) + if (scan() != EOF) { + call garg$t (px1) + if (nscan() == 1) { + if (!IS_$INDEF (px1)) { + j = icg_nearest$t (ic, gp, gt, cv, x, y, n, + wx, wy) + if (j != 0) + if (x[j] == Mem$t[x1+i-1] && + y[j] == Mem$t[y1+i-1]) + y[j] = px1 + Mem$t[y1+i-1] = px1 + call ic_gui (ic, "refit YES") + IC_NEWY(ic) = YES + } + } + } + } + } + + case 'z': # Delete sample region + if (x1 == NULL) + call icg_dsample$t (wx, wy, ic, gp, gt, x, n) + else + call icg_dsample$t (wx, wy, ic, gp, gt, Mem$t[x1], n) + call ic_pstr (ic, "sample", Memc[IC_SAMPLE(ic)]) + + case 'I': # Interrupt + call fatal (0, "Interrupt") + + default: # Let the user decide on any other keys. + call icg_user (ic, gp, gt, cv, wx, wy, wcs, key, Memc[cmd]) + } + + # Redraw the graph if necessary. +10 if (newgraph == YES) { + if (IC_AXES(ic, IC_GKEY(ic), 1) != axes[1]) { + axes[1] = IC_AXES(ic, IC_GKEY(ic), 1) + call gt_setr (gt, GTXMIN, INDEFR) + call gt_setr (gt, GTXMAX, INDEFR) + } + if (IC_AXES(ic, IC_GKEY(ic), 2) != axes[2]) { + axes[2] = IC_AXES(ic, IC_GKEY(ic), 2) + call gt_setr (gt, GTYMIN, INDEFR) + call gt_setr (gt, GTYMAX, INDEFR) + } + if (x1 == NULL) + call icg_graph$t (ic, gp, gt, cv, x, y, wts, n) + else + call icg_graph$t (ic, gp, gt, cv, Mem$t[x1], Mem$t[y1], + Mem$t[w1], n) + newgraph = NO + } + if (cursor[1] == EOS) + break + } until (gt_gcur1 (gt, cursor, wx, wy, wcs, key, Memc[cmd], + IC_SZSAMPLE) == EOF) + + call ic_gui (ic, "close") + IC_GP(ic) = NULL + + if (x1 != NULL) { + call mfree (x1, TY_PIXEL) + call mfree (y1, TY_PIXEL) + call mfree (w1, TY_PIXEL) + if (IC_WTSFIT(ic) == NULL) + IC_NFIT(ic) = npts + } + call mfree (userwts, TY_PIXEL) + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgfitd.x b/pkg/xtools/icfit/icgfitd.x new file mode 100644 index 00000000..ee66e9b3 --- /dev/null +++ b/pkg/xtools/icfit/icgfitd.x @@ -0,0 +1,544 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <pkg/gtools.h> +include "names.h" +include "icfit.h" + +# ICG_FIT -- Interactive curve fitting with graphics. This is the main +# entry point for the interactive graphics part of the icfit package. + +procedure icg_fitd (ic, gp, cursor, gt, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +char cursor[ARB] # GIO cursor input +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +double x[npts] # Ordinates +double y[npts] # Abscissas +double wts[npts] # Weights +int npts # Number of points + +real wx, wy +int wcs, key + +int i, j, newgraph, axes[2], xtype +double px1 +real rx1, rx2, ry1, ry2 +pointer sp, cmd, userwts, x1, y1, w1, n + +int gt_gcur1(), stridxs(), scan(), nscan() +int icg_nearestd() +double dcveval() +errchk ic_fitd() + +begin + call smark (sp) + call salloc (cmd, IC_SZSAMPLE, TY_CHAR) + + # Allocate memory for the fit and a copy of the weights. + # The weights are copied because they are changed when points are + # deleted. + + n = npts + x1 = NULL + y1 = NULL + w1 = NULL + call malloc (userwts, n, TY_DOUBLE) + call amovd (wts, Memd[userwts], n) + + # Initialize + IC_GP(ic) = gp + IC_GT(ic) = gt + IC_OVERPLOT(ic) = NO + IC_NEWX(ic) = YES + IC_NEWY(ic) = YES + IC_NEWWTS(ic) = YES + IC_NEWFUNCTION(ic) = YES + + # Send the GUI the current task values. + call ic_gui (ic, "open") + call ic_gui (ic, "graph") + + # Read cursor commands. + + key = 'f' + newgraph = YES + axes[1] = IC_AXES(ic, IC_GKEY(ic), 1) + axes[2] = IC_AXES(ic, IC_GKEY(ic), 2) + xtype = 0 + + repeat { + switch (key) { + case '?': # Print help text. + call ic_gui (ic, "help") + + case ':': # List or set parameters + if (Memc[cmd] == '/') + call gt_colon (Memc[cmd], gp, gt, newgraph) + else + call icg_colond (ic, Memc[cmd], newgraph, gp, gt, cv, + x, y, wts, n) + + case 'a': # Add points + if ((IC_AXES(ic,IC_GKEY(ic),1) == 'x') && + (IC_AXES(ic,IC_GKEY(ic),2) == 'y')) + ; + else if ((IC_AXES(ic,IC_GKEY(ic),1) == 'y') && + (IC_AXES(ic,IC_GKEY(ic),2) == 'x')) { + rx1 = wx + wx = wy + wy = rx1 + } else { + call printf ("Graph must be x vs. y or y vs. x\07\n") + next + } + + rx1 = 1. + call printf ("weight = (%g) ") + call pargr (rx1) + call flush (STDOUT) + if (scan() != EOF) { + call gargr (rx2) + if (nscan() == 1) + if (!IS_INDEFR (rx2)) + rx1 = rx2 + } + + if (x1 == NULL) { + call malloc (x1, n+1, TY_DOUBLE) + call malloc (y1, n+1, TY_DOUBLE) + call malloc (w1, n+1, TY_DOUBLE) + call amovd (x, Memd[x1], n) + call amovd (y, Memd[y1], n) + call amovd (wts, Memd[w1], n) + } else { + call realloc (x1, n+1, TY_DOUBLE) + call realloc (y1, n+1, TY_DOUBLE) + call realloc (w1, n+1, TY_DOUBLE) + } + call realloc (userwts, n+1, TY_DOUBLE) + + call icg_addd (gp, wx, wy, rx1, Memd[x1], Memd[y1], + Memd[w1], Memd[userwts], n) + + IC_NEWX(ic) = YES + IC_NEWY(ic) = YES + IC_NEWWTS(ic) = YES + + case 'c': # Print the positions of data points. + if (x1 == NULL) { + i = icg_nearestd (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("x = %g y = %g fit = %g\n") + call pargd (x[i]) + call pargd (y[i]) + call pargd (dcveval (cv, x[i])) + } + } else { + i = icg_nearestd (ic, gp, gt, cv, Memd[x1], Memd[y1], + n, wx, wy) + + if (i != 0) { + call printf ("x = %g y = %g fit = %g\n") + call pargd (Memd[x1+i-1]) + call pargd (Memd[y1+i-1]) + call pargd (dcveval (cv, Memd[x1+i-1])) + } + } + + case 'd': # Delete data points. + if (x1 == NULL) + call icg_deleted (ic, gp, gt, cv, x, y, wts, + Memd[userwts], n, wx, wy) + else + call icg_deleted (ic, gp, gt, cv, Memd[x1], Memd[y1], + Memd[w1], Memd[userwts], n, wx, wy) + call ic_gui (ic, "refit YES") + + case 'f': # Fit the function and reset the flags. + iferr { + if (x1 == NULL) + call ic_fitd (ic, cv, x, y, wts, n, IC_NEWX(ic), + IC_NEWY(ic), IC_NEWWTS(ic), IC_NEWFUNCTION(ic)) + else + call ic_fitd (ic, cv, Memd[x1], Memd[y1], Memd[w1], + n, IC_NEWX(ic), IC_NEWY(ic), IC_NEWWTS(ic), + IC_NEWFUNCTION(ic)) + + IC_NEWX(ic) = NO + IC_NEWY(ic) = NO + IC_NEWWTS(ic) = NO + IC_NEWFUNCTION(ic) = NO + IC_FITERROR(ic) = NO + newgraph = YES + + call ic_gui (ic, "refit NO") + } then { + IC_FITERROR(ic) = YES + call erract (EA_WARN) + } + + case 'g': # Set graph axes types. + call printf ("Graph key to be defined: ") + call flush (STDOUT) + if (scan() == EOF) + goto 10 + call gargc (Memc[cmd]) + + switch (Memc[cmd]) { + case '\n': + case 'h', 'i', 'j', 'k', 'l': + switch (Memc[cmd]) { + case 'h': + key = 1 + case 'i': + key = 2 + case 'j': + key = 3 + case 'k': + key = 4 + case 'l': + key = 5 + } + + call printf ("Set graph axes types (%c, %c): ") + call pargi (IC_AXES(ic, key, 1)) + call pargi (IC_AXES(ic, key, 2)) + call flush (STDOUT) + if (scan() == EOF) + goto 10 + call gargc (Memc[cmd]) + + switch (Memc[cmd]) { + case '\n': + default: + call gargc (Memc[cmd+1]) + call gargc (Memc[cmd+1]) + if (Memc[cmd+1] != '\n') { + IC_AXES(ic, key, 1) = Memc[cmd] + IC_AXES(ic, key, 2) = Memc[cmd+1] + if (IC_GKEY(ic) == key) + newgraph = YES + } + } + default: + call printf ("Not a graph key\n") + } + + case 'h': + if (IC_GKEY(ic) != 1) { + IC_GKEY(ic) = 1 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'i': + if (IC_GKEY(ic) != 2) { + IC_GKEY(ic) = 2 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'j': + if (IC_GKEY(ic) != 3) { + IC_GKEY(ic) = 3 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'k': + if (IC_GKEY(ic) != 4) { + IC_GKEY(ic) = 4 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'l': + if (IC_GKEY(ic) != 5) { + IC_GKEY(ic) = 5 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 't': # Initialize the sample string and erase from the graph. + if (x1 == NULL) + call icg_sampled (ic, gp, gt, x, n, 0) + else + call icg_sampled (ic, gp, gt, Memd[x1], n, 0) + call ic_pstr (ic, "sample", "*") + IC_NEWX(ic) = YES + + case 'o': # Set overplot flag + IC_OVERPLOT(ic) = YES + + case 'r': # Redraw the graph + newgraph = YES + + case 's': # Set sample regions with the cursor. + if ((IC_AXES(ic,IC_GKEY(ic),1) == 'x') || + (IC_AXES(ic,IC_GKEY(ic),2) == 'x')) { + if (stridxs ("*", Memc[IC_SAMPLE(ic)]) > 0) + Memc[IC_SAMPLE(ic)] = EOS + + rx1 = wx + ry1 = wy + call printf ("again:\n") + if (gt_gcur1(gt, cursor, wx, wy, wcs, key, Memc[cmd], + IC_SZSAMPLE) == EOF) + break + call printf ("\n") + rx2 = wx + ry2 = wy + + # Determine if the x vector is integer. + if (xtype == 0) { + xtype = TY_INT + if (x1 == NULL) { + do i = 1, n + if (x[i] != int (x[i])) { + xtype = TY_REAL + break + } + } else { + do i = 1, n + if (Memd[x1+i-1] != int (Memd[x1+i-1])) { + xtype = TY_REAL + break + } + } + } + + if (IC_AXES(ic,IC_GKEY(ic),1) == 'x') { + if (xtype == TY_INT) { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %d:%d") + call pargi (nint (rx1)) + call pargi (nint (rx2)) + } else { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %g:%g") + call pargr (rx1) + call pargr (rx2) + } + } else { + if (xtype == TY_INT) { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %d:%d") + call pargi (nint (ry1)) + call pargi (nint (ry2)) + } else { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %g:%g") + call pargr (ry1) + call pargr (ry2) + } + } + call strcat (Memc[cmd], Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + if (x1 == NULL) + call icg_sampled (ic, gp, gt, x, n, 1) + else + call icg_sampled (ic, gp, gt, Memd[x1], n, 1) + call ic_pstr (ic, "sample", Memc[IC_SAMPLE(ic)]) + IC_NEWX(ic) = YES + } + + case 'u': # Undelete data points. + if (x1 == NULL) + call icg_undeleted (ic, gp, gt, cv, x, y, wts, + Memd[userwts], n, wx, wy) + else + call icg_undeleted (ic, gp, gt, cv, Memd[x1], Memd[y1], + Memd[w1], Memd[userwts], n, wx, wy) + call ic_gui (ic, "refit YES") + + case 'w': # Window graph + call gt_window (gt, gp, cursor, newgraph) + + case 'v': # Reset the value of the weight. + if (x1 == NULL) { + i = icg_nearestd (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("weight = (%g) ") + call pargd (wts[i]) + call flush (STDOUT) + if (scan() != EOF) { + call gargd (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + wts[i] = px1 + call ic_gui (ic, "refit YES") + IC_NEWWTS(ic) = YES + } + } + } + } + } else { + i = icg_nearestd (ic, gp, gt, cv, Memd[x1], Memd[y1], n, + wx, wy) + + if (i != 0) { + call printf ("weight = (%g) ") + call pargd (Memd[w1+i-1]) + call flush (STDOUT) + if (scan() != EOF) { + call gargd (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + j = icg_nearestd (ic, gp, gt, cv, x, y, n, + wx, wy) + if (j != 0) + if (x[j] == Memd[x1+i-1] && + y[j] == Memd[y1+i-1]) + wts[j] = px1 + Memd[w1+i-1] = px1 + call ic_gui (ic, "refit YES") + IC_NEWWTS(ic) = YES + } + } + } + } + } + + case 'x': # Reset the value of the x point. + if (x1 == NULL) { + i = icg_nearestd (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("x = (%g) ") + call pargd (x[i]) + call flush (STDOUT) + if (scan() != EOF) { + call gargd (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + x[i] = px1 + call ic_gui (ic, "refit YES") + IC_NEWX(ic) = YES + } + } + } + } + } else { + i = icg_nearestd (ic, gp, gt, cv, Memd[x1], Memd[y1], n, + wx, wy) + + if (i != 0) { + call printf ("x = (%g) ") + call pargd (Memd[x1+i-1]) + call flush (STDOUT) + if (scan() != EOF) { + call gargd (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + j = icg_nearestd (ic, gp, gt, cv, x, y, n, + wx, wy) + if (j != 0) + if (x[j] == Memd[x1+i-1] && + y[j] == Memd[y1+i-1]) + x[j] = px1 + Memd[x1+i-1] = px1 + call ic_gui (ic, "refit YES") + IC_NEWX(ic) = YES + } + } + } + } + } + + case 'y': # Reset the value of the y point. + if (x1 == NULL) { + i = icg_nearestd (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("y = (%g) ") + call pargd (y[i]) + call flush (STDOUT) + if (scan() != EOF) { + call gargd (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + y[i] = px1 + call ic_gui (ic, "refit YES") + IC_NEWY(ic) = YES + } + } + } + } + } else { + i = icg_nearestd (ic, gp, gt, cv, Memd[x1], Memd[y1], n, + wx, wy) + + if (i != 0) { + call printf ("y = (%g) ") + call pargd (Memd[y1+i-1]) + call flush (STDOUT) + if (scan() != EOF) { + call gargd (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + j = icg_nearestd (ic, gp, gt, cv, x, y, n, + wx, wy) + if (j != 0) + if (x[j] == Memd[x1+i-1] && + y[j] == Memd[y1+i-1]) + y[j] = px1 + Memd[y1+i-1] = px1 + call ic_gui (ic, "refit YES") + IC_NEWY(ic) = YES + } + } + } + } + } + + case 'z': # Delete sample region + if (x1 == NULL) + call icg_dsampled (wx, wy, ic, gp, gt, x, n) + else + call icg_dsampled (wx, wy, ic, gp, gt, Memd[x1], n) + call ic_pstr (ic, "sample", Memc[IC_SAMPLE(ic)]) + + case 'I': # Interrupt + call fatal (0, "Interrupt") + + default: # Let the user decide on any other keys. + call icg_user (ic, gp, gt, cv, wx, wy, wcs, key, Memc[cmd]) + } + + # Redraw the graph if necessary. +10 if (newgraph == YES) { + if (IC_AXES(ic, IC_GKEY(ic), 1) != axes[1]) { + axes[1] = IC_AXES(ic, IC_GKEY(ic), 1) + call gt_setr (gt, GTXMIN, INDEFR) + call gt_setr (gt, GTXMAX, INDEFR) + } + if (IC_AXES(ic, IC_GKEY(ic), 2) != axes[2]) { + axes[2] = IC_AXES(ic, IC_GKEY(ic), 2) + call gt_setr (gt, GTYMIN, INDEFR) + call gt_setr (gt, GTYMAX, INDEFR) + } + if (x1 == NULL) + call icg_graphd (ic, gp, gt, cv, x, y, wts, n) + else + call icg_graphd (ic, gp, gt, cv, Memd[x1], Memd[y1], + Memd[w1], n) + newgraph = NO + } + if (cursor[1] == EOS) + break + } until (gt_gcur1 (gt, cursor, wx, wy, wcs, key, Memc[cmd], + IC_SZSAMPLE) == EOF) + + call ic_gui (ic, "close") + IC_GP(ic) = NULL + + if (x1 != NULL) { + call mfree (x1, TY_DOUBLE) + call mfree (y1, TY_DOUBLE) + call mfree (w1, TY_DOUBLE) + if (IC_WTSFIT(ic) == NULL) + IC_NFIT(ic) = npts + } + call mfree (userwts, TY_DOUBLE) + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgfitr.x b/pkg/xtools/icfit/icgfitr.x new file mode 100644 index 00000000..d10c1607 --- /dev/null +++ b/pkg/xtools/icfit/icgfitr.x @@ -0,0 +1,544 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <pkg/gtools.h> +include "names.h" +include "icfit.h" + +# ICG_FIT -- Interactive curve fitting with graphics. This is the main +# entry point for the interactive graphics part of the icfit package. + +procedure icg_fitr (ic, gp, cursor, gt, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +char cursor[ARB] # GIO cursor input +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +real x[npts] # Ordinates +real y[npts] # Abscissas +real wts[npts] # Weights +int npts # Number of points + +real wx, wy +int wcs, key + +int i, j, newgraph, axes[2], xtype +real px1 +real rx1, rx2, ry1, ry2 +pointer sp, cmd, userwts, x1, y1, w1, n + +int gt_gcur1(), stridxs(), scan(), nscan() +int icg_nearestr() +real rcveval() +errchk ic_fitr() + +begin + call smark (sp) + call salloc (cmd, IC_SZSAMPLE, TY_CHAR) + + # Allocate memory for the fit and a copy of the weights. + # The weights are copied because they are changed when points are + # deleted. + + n = npts + x1 = NULL + y1 = NULL + w1 = NULL + call malloc (userwts, n, TY_REAL) + call amovr (wts, Memr[userwts], n) + + # Initialize + IC_GP(ic) = gp + IC_GT(ic) = gt + IC_OVERPLOT(ic) = NO + IC_NEWX(ic) = YES + IC_NEWY(ic) = YES + IC_NEWWTS(ic) = YES + IC_NEWFUNCTION(ic) = YES + + # Send the GUI the current task values. + call ic_gui (ic, "open") + call ic_gui (ic, "graph") + + # Read cursor commands. + + key = 'f' + newgraph = YES + axes[1] = IC_AXES(ic, IC_GKEY(ic), 1) + axes[2] = IC_AXES(ic, IC_GKEY(ic), 2) + xtype = 0 + + repeat { + switch (key) { + case '?': # Print help text. + call ic_gui (ic, "help") + + case ':': # List or set parameters + if (Memc[cmd] == '/') + call gt_colon (Memc[cmd], gp, gt, newgraph) + else + call icg_colonr (ic, Memc[cmd], newgraph, gp, gt, cv, + x, y, wts, n) + + case 'a': # Add points + if ((IC_AXES(ic,IC_GKEY(ic),1) == 'x') && + (IC_AXES(ic,IC_GKEY(ic),2) == 'y')) + ; + else if ((IC_AXES(ic,IC_GKEY(ic),1) == 'y') && + (IC_AXES(ic,IC_GKEY(ic),2) == 'x')) { + rx1 = wx + wx = wy + wy = rx1 + } else { + call printf ("Graph must be x vs. y or y vs. x\07\n") + next + } + + rx1 = 1. + call printf ("weight = (%g) ") + call pargr (rx1) + call flush (STDOUT) + if (scan() != EOF) { + call gargr (rx2) + if (nscan() == 1) + if (!IS_INDEFR (rx2)) + rx1 = rx2 + } + + if (x1 == NULL) { + call malloc (x1, n+1, TY_REAL) + call malloc (y1, n+1, TY_REAL) + call malloc (w1, n+1, TY_REAL) + call amovr (x, Memr[x1], n) + call amovr (y, Memr[y1], n) + call amovr (wts, Memr[w1], n) + } else { + call realloc (x1, n+1, TY_REAL) + call realloc (y1, n+1, TY_REAL) + call realloc (w1, n+1, TY_REAL) + } + call realloc (userwts, n+1, TY_REAL) + + call icg_addr (gp, wx, wy, rx1, Memr[x1], Memr[y1], + Memr[w1], Memr[userwts], n) + + IC_NEWX(ic) = YES + IC_NEWY(ic) = YES + IC_NEWWTS(ic) = YES + + case 'c': # Print the positions of data points. + if (x1 == NULL) { + i = icg_nearestr (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("x = %g y = %g fit = %g\n") + call pargr (x[i]) + call pargr (y[i]) + call pargr (rcveval (cv, x[i])) + } + } else { + i = icg_nearestr (ic, gp, gt, cv, Memr[x1], Memr[y1], + n, wx, wy) + + if (i != 0) { + call printf ("x = %g y = %g fit = %g\n") + call pargr (Memr[x1+i-1]) + call pargr (Memr[y1+i-1]) + call pargr (rcveval (cv, Memr[x1+i-1])) + } + } + + case 'd': # Delete data points. + if (x1 == NULL) + call icg_deleter (ic, gp, gt, cv, x, y, wts, + Memr[userwts], n, wx, wy) + else + call icg_deleter (ic, gp, gt, cv, Memr[x1], Memr[y1], + Memr[w1], Memr[userwts], n, wx, wy) + call ic_gui (ic, "refit YES") + + case 'f': # Fit the function and reset the flags. + iferr { + if (x1 == NULL) + call ic_fitr (ic, cv, x, y, wts, n, IC_NEWX(ic), + IC_NEWY(ic), IC_NEWWTS(ic), IC_NEWFUNCTION(ic)) + else + call ic_fitr (ic, cv, Memr[x1], Memr[y1], Memr[w1], + n, IC_NEWX(ic), IC_NEWY(ic), IC_NEWWTS(ic), + IC_NEWFUNCTION(ic)) + + IC_NEWX(ic) = NO + IC_NEWY(ic) = NO + IC_NEWWTS(ic) = NO + IC_NEWFUNCTION(ic) = NO + IC_FITERROR(ic) = NO + newgraph = YES + + call ic_gui (ic, "refit NO") + } then { + IC_FITERROR(ic) = YES + call erract (EA_WARN) + } + + case 'g': # Set graph axes types. + call printf ("Graph key to be defined: ") + call flush (STDOUT) + if (scan() == EOF) + goto 10 + call gargc (Memc[cmd]) + + switch (Memc[cmd]) { + case '\n': + case 'h', 'i', 'j', 'k', 'l': + switch (Memc[cmd]) { + case 'h': + key = 1 + case 'i': + key = 2 + case 'j': + key = 3 + case 'k': + key = 4 + case 'l': + key = 5 + } + + call printf ("Set graph axes types (%c, %c): ") + call pargi (IC_AXES(ic, key, 1)) + call pargi (IC_AXES(ic, key, 2)) + call flush (STDOUT) + if (scan() == EOF) + goto 10 + call gargc (Memc[cmd]) + + switch (Memc[cmd]) { + case '\n': + default: + call gargc (Memc[cmd+1]) + call gargc (Memc[cmd+1]) + if (Memc[cmd+1] != '\n') { + IC_AXES(ic, key, 1) = Memc[cmd] + IC_AXES(ic, key, 2) = Memc[cmd+1] + if (IC_GKEY(ic) == key) + newgraph = YES + } + } + default: + call printf ("Not a graph key\n") + } + + case 'h': + if (IC_GKEY(ic) != 1) { + IC_GKEY(ic) = 1 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'i': + if (IC_GKEY(ic) != 2) { + IC_GKEY(ic) = 2 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'j': + if (IC_GKEY(ic) != 3) { + IC_GKEY(ic) = 3 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'k': + if (IC_GKEY(ic) != 4) { + IC_GKEY(ic) = 4 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 'l': + if (IC_GKEY(ic) != 5) { + IC_GKEY(ic) = 5 + newgraph = YES + call ic_gui (ic, "graph") + } + + case 't': # Initialize the sample string and erase from the graph. + if (x1 == NULL) + call icg_sampler (ic, gp, gt, x, n, 0) + else + call icg_sampler (ic, gp, gt, Memr[x1], n, 0) + call ic_pstr (ic, "sample", "*") + IC_NEWX(ic) = YES + + case 'o': # Set overplot flag + IC_OVERPLOT(ic) = YES + + case 'r': # Redraw the graph + newgraph = YES + + case 's': # Set sample regions with the cursor. + if ((IC_AXES(ic,IC_GKEY(ic),1) == 'x') || + (IC_AXES(ic,IC_GKEY(ic),2) == 'x')) { + if (stridxs ("*", Memc[IC_SAMPLE(ic)]) > 0) + Memc[IC_SAMPLE(ic)] = EOS + + rx1 = wx + ry1 = wy + call printf ("again:\n") + if (gt_gcur1(gt, cursor, wx, wy, wcs, key, Memc[cmd], + IC_SZSAMPLE) == EOF) + break + call printf ("\n") + rx2 = wx + ry2 = wy + + # Determine if the x vector is integer. + if (xtype == 0) { + xtype = TY_INT + if (x1 == NULL) { + do i = 1, n + if (x[i] != int (x[i])) { + xtype = TY_REAL + break + } + } else { + do i = 1, n + if (Memr[x1+i-1] != int (Memr[x1+i-1])) { + xtype = TY_REAL + break + } + } + } + + if (IC_AXES(ic,IC_GKEY(ic),1) == 'x') { + if (xtype == TY_INT) { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %d:%d") + call pargi (nint (rx1)) + call pargi (nint (rx2)) + } else { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %g:%g") + call pargr (rx1) + call pargr (rx2) + } + } else { + if (xtype == TY_INT) { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %d:%d") + call pargi (nint (ry1)) + call pargi (nint (ry2)) + } else { + call sprintf (Memc[cmd], IC_SZSAMPLE, " %g:%g") + call pargr (ry1) + call pargr (ry2) + } + } + call strcat (Memc[cmd], Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + if (x1 == NULL) + call icg_sampler (ic, gp, gt, x, n, 1) + else + call icg_sampler (ic, gp, gt, Memr[x1], n, 1) + call ic_pstr (ic, "sample", Memc[IC_SAMPLE(ic)]) + IC_NEWX(ic) = YES + } + + case 'u': # Undelete data points. + if (x1 == NULL) + call icg_undeleter (ic, gp, gt, cv, x, y, wts, + Memr[userwts], n, wx, wy) + else + call icg_undeleter (ic, gp, gt, cv, Memr[x1], Memr[y1], + Memr[w1], Memr[userwts], n, wx, wy) + call ic_gui (ic, "refit YES") + + case 'w': # Window graph + call gt_window (gt, gp, cursor, newgraph) + + case 'v': # Reset the value of the weight. + if (x1 == NULL) { + i = icg_nearestr (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("weight = (%g) ") + call pargr (wts[i]) + call flush (STDOUT) + if (scan() != EOF) { + call gargr (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + wts[i] = px1 + call ic_gui (ic, "refit YES") + IC_NEWWTS(ic) = YES + } + } + } + } + } else { + i = icg_nearestr (ic, gp, gt, cv, Memr[x1], Memr[y1], n, + wx, wy) + + if (i != 0) { + call printf ("weight = (%g) ") + call pargr (Memr[w1+i-1]) + call flush (STDOUT) + if (scan() != EOF) { + call gargr (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + j = icg_nearestr (ic, gp, gt, cv, x, y, n, + wx, wy) + if (j != 0) + if (x[j] == Memr[x1+i-1] && + y[j] == Memr[y1+i-1]) + wts[j] = px1 + Memr[w1+i-1] = px1 + call ic_gui (ic, "refit YES") + IC_NEWWTS(ic) = YES + } + } + } + } + } + + case 'x': # Reset the value of the x point. + if (x1 == NULL) { + i = icg_nearestr (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("x = (%g) ") + call pargr (x[i]) + call flush (STDOUT) + if (scan() != EOF) { + call gargr (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + x[i] = px1 + call ic_gui (ic, "refit YES") + IC_NEWX(ic) = YES + } + } + } + } + } else { + i = icg_nearestr (ic, gp, gt, cv, Memr[x1], Memr[y1], n, + wx, wy) + + if (i != 0) { + call printf ("x = (%g) ") + call pargr (Memr[x1+i-1]) + call flush (STDOUT) + if (scan() != EOF) { + call gargr (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + j = icg_nearestr (ic, gp, gt, cv, x, y, n, + wx, wy) + if (j != 0) + if (x[j] == Memr[x1+i-1] && + y[j] == Memr[y1+i-1]) + x[j] = px1 + Memr[x1+i-1] = px1 + call ic_gui (ic, "refit YES") + IC_NEWX(ic) = YES + } + } + } + } + } + + case 'y': # Reset the value of the y point. + if (x1 == NULL) { + i = icg_nearestr (ic, gp, gt, cv, x, y, n, wx, wy) + + if (i != 0) { + call printf ("y = (%g) ") + call pargr (y[i]) + call flush (STDOUT) + if (scan() != EOF) { + call gargr (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + y[i] = px1 + call ic_gui (ic, "refit YES") + IC_NEWY(ic) = YES + } + } + } + } + } else { + i = icg_nearestr (ic, gp, gt, cv, Memr[x1], Memr[y1], n, + wx, wy) + + if (i != 0) { + call printf ("y = (%g) ") + call pargr (Memr[y1+i-1]) + call flush (STDOUT) + if (scan() != EOF) { + call gargr (px1) + if (nscan() == 1) { + if (!IS_INDEF (px1)) { + j = icg_nearestr (ic, gp, gt, cv, x, y, n, + wx, wy) + if (j != 0) + if (x[j] == Memr[x1+i-1] && + y[j] == Memr[y1+i-1]) + y[j] = px1 + Memr[y1+i-1] = px1 + call ic_gui (ic, "refit YES") + IC_NEWY(ic) = YES + } + } + } + } + } + + case 'z': # Delete sample region + if (x1 == NULL) + call icg_dsampler (wx, wy, ic, gp, gt, x, n) + else + call icg_dsampler (wx, wy, ic, gp, gt, Memr[x1], n) + call ic_pstr (ic, "sample", Memc[IC_SAMPLE(ic)]) + + case 'I': # Interrupt + call fatal (0, "Interrupt") + + default: # Let the user decide on any other keys. + call icg_user (ic, gp, gt, cv, wx, wy, wcs, key, Memc[cmd]) + } + + # Redraw the graph if necessary. +10 if (newgraph == YES) { + if (IC_AXES(ic, IC_GKEY(ic), 1) != axes[1]) { + axes[1] = IC_AXES(ic, IC_GKEY(ic), 1) + call gt_setr (gt, GTXMIN, INDEFR) + call gt_setr (gt, GTXMAX, INDEFR) + } + if (IC_AXES(ic, IC_GKEY(ic), 2) != axes[2]) { + axes[2] = IC_AXES(ic, IC_GKEY(ic), 2) + call gt_setr (gt, GTYMIN, INDEFR) + call gt_setr (gt, GTYMAX, INDEFR) + } + if (x1 == NULL) + call icg_graphr (ic, gp, gt, cv, x, y, wts, n) + else + call icg_graphr (ic, gp, gt, cv, Memr[x1], Memr[y1], + Memr[w1], n) + newgraph = NO + } + if (cursor[1] == EOS) + break + } until (gt_gcur1 (gt, cursor, wx, wy, wcs, key, Memc[cmd], + IC_SZSAMPLE) == EOF) + + call ic_gui (ic, "close") + IC_GP(ic) = NULL + + if (x1 != NULL) { + call mfree (x1, TY_REAL) + call mfree (y1, TY_REAL) + call mfree (w1, TY_REAL) + if (IC_WTSFIT(ic) == NULL) + IC_NFIT(ic) = npts + } + call mfree (userwts, TY_REAL) + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icggraph.gx b/pkg/xtools/icfit/icggraph.gx new file mode 100644 index 00000000..393582db --- /dev/null +++ b/pkg/xtools/icfit/icggraph.gx @@ -0,0 +1,226 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <pkg/gtools.h> +include "names.h" +include "icfit.h" + +define NGRAPH 100 # Number of fit points to graph +define MSIZE 2. # Mark size + +# ICG_GRAPH -- Graph data and fit. + +procedure icg_graph$t (ic, gp, gt, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointers +pointer cv # Curfit pointer +PIXEL x[npts] # Independent variable +PIXEL y[npts] # Dependent variable +PIXEL wts[npts] # Weights +int npts # Number of points + +pointer xout, yout +real size + +begin + call malloc (xout, npts, TY_PIXEL) + call malloc (yout, npts, TY_PIXEL) + call icg_axes$t (ic, gt, cv, 1, x, y, Mem$t[xout], npts) + call icg_axes$t (ic, gt, cv, 2, x, y, Mem$t[yout], npts) + call icg_params$t (ic, cv, x, y, wts, npts, gt) + + call icg_g1$t (ic, gp, gt, Mem$t[xout], Mem$t[yout], wts, npts) + + # Symbol size for averaged ranges. + size = abs(IC_NAVERAGE(ic) * (Mem$t[xout+npts-1] - Mem$t[xout]) / + float(npts)) + + if (npts != IC_NFIT(ic)) { + if ((abs (IC_NAVERAGE(ic)) > 1) || (IC_NREJECT(ic) > 0)) { + call realloc (xout, IC_NFIT(ic), TY_PIXEL) + call realloc (yout, IC_NFIT(ic), TY_PIXEL) + call icg_axes$t (ic, gt, cv, 1, Mem$t[IC_XFIT(ic)], + Mem$t[IC_YFIT(ic)], Mem$t[xout], IC_NFIT(ic)) + call icg_axes$t (ic, gt, cv, 2, Mem$t[IC_XFIT(ic)], + Mem$t[IC_YFIT(ic)], Mem$t[yout], IC_NFIT(ic)) + call icg_g2$t (ic, gp, gt, Mem$t[xout], Mem$t[yout], + IC_NFIT(ic), size) + } + + } else if (IC_NREJECT(ic) > 0) + call icg_g2$t (ic, gp, gt, Mem$t[xout], Mem$t[yout], npts, size) + + call icg_gf$t (ic, gp, gt, cv, max (npts, NGRAPH)) + + # Mark the the sample regions. + + call icg_sample$t (ic, gp, gt, x, npts, 1) + + # Send the wcs to the gui. + call ic_gui (ic, "wcs") + + call mfree (xout, TY_PIXEL) + call mfree (yout, TY_PIXEL) +end + +procedure icg_g1$t (ic, gp, gt, x, y, wts, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +PIXEL x[npts] # Ordinates +PIXEL y[npts] # Abscissas +PIXEL wts[npts] # Weights +int npts # Number of points + +int i +pointer sp, xr, yr, xr1, yr1, gt1 + +begin + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (xr1, 2, TY_REAL) + call salloc (yr1, 2, TY_REAL) + call acht$tr (x, Memr[xr], npts) + call acht$tr (y, Memr[yr], npts) + + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "cross") + + if (IC_OVERPLOT(ic) == NO) { + # Start a new plot. + + call gclear (gp) + + # Set the graph scale and axes. + + call gascale (gp, Memr[xr], npts, 1) + call gascale (gp, Memr[yr], npts, 2) + call gt_swind (gp, gt) + call gt_labax (gp, gt) + } + + if (IC_OVERPLOT(ic) == NO) { + Memr[xr1] = Memr[xr] + Memr[yr1] = Memr[yr] + do i = 1, npts { + if (wts[i] == 0.) { + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } else { + Memr[xr1+1] = Memr[xr+i-1] + Memr[yr1+1] = Memr[yr+i-1] + call gt_plot (gp, gt, Memr[xr1], Memr[yr1], 2) + Memr[xr1] = Memr[xr1+1] + Memr[yr1] = Memr[yr1+1] + } + } + } + + # Reset status flags. + + IC_OVERPLOT(ic) = NO + + call sfree (sp) + call gt_free (gt1) +end + +procedure icg_g2$t (ic, gp, gt, x, y, npts, size) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +PIXEL x[npts], y[npts] # Data points +int npts # Number of data points +real size # Symbol size + +int i +pointer sp, xr, yr, gt1 + +begin + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call acht$tr (x, Memr[xr], npts) + call acht$tr (y, Memr[yr], npts) + + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + + # Mark the sample points. + + if (abs (IC_NAVERAGE(ic)) > 1) { + call gt_sets (gt1, GTMARK, "plus") + call gt_setr (gt1, GTXSIZE, -size) + call gt_setr (gt1, GTYSIZE, 1.) + call gt_plot (gp, gt1, Memr[xr], Memr[yr], npts) + } + + # Mark the rejected points. + + if (IC_NREJECT(ic) > 0 && IC_MARKREJ(ic) == YES) { + call gt_sets (gt1, GTMARK, "diamond") + call gt_setr (gt1, GTXSIZE, MSIZE) + call gt_setr (gt1, GTYSIZE, MSIZE) + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } + } + + call gt_free (gt1) + call sfree (sp) +end + +procedure icg_gf$t (ic, gp, gt, cv, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOL pointer +pointer cv # CURFIT pointer +int npts # Number of points to plot + +pointer sp, xr, yr, x, y, xo, yo, gt1 +int i +PIXEL dx + +begin + if (IC_FITERROR(ic) == YES) + return + + call smark (sp) + + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (x, npts, TY_PIXEL) + call salloc (y, npts, TY_PIXEL) + call salloc (xo, npts, TY_PIXEL) + call salloc (yo, npts, TY_PIXEL) + + # Generate vector of independent variable values + dx = (IC_XMAX(ic) - IC_XMIN(ic)) / (npts - 1) + do i = 1, npts + Mem$t[x+i-1] = IC_XMIN(ic) + (i-1) * dx + + # Calculate vector of fit values. + call $tcvvector (cv, Mem$t[x], Mem$t[y], npts) + + # Convert to user function or transpose axes. Change type to reals + # for plotting. + call icg_axes$t (ic, gt, cv, 1, Mem$t[x], Mem$t[y], Mem$t[xo], npts) + call icg_axes$t (ic, gt, cv, 2, Mem$t[x], Mem$t[y], Mem$t[yo], npts) + call acht$tr (Mem$t[xo], Memr[xr], npts) + call acht$tr (Mem$t[yo], Memr[yr], npts) + + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "line") + call gt_seti (gt1, GTLINE, GL_DASHED) + call gt_seti (gt1, GTCOLOR, max (0, min (9, IC_COLOR(ic)))) + call gt_plot (gp, gt1, Memr[xr], Memr[yr], npts) + call gt_free (gt1) + + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icggraphd.x b/pkg/xtools/icfit/icggraphd.x new file mode 100644 index 00000000..03994a14 --- /dev/null +++ b/pkg/xtools/icfit/icggraphd.x @@ -0,0 +1,226 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <pkg/gtools.h> +include "names.h" +include "icfit.h" + +define NGRAPH 100 # Number of fit points to graph +define MSIZE 2. # Mark size + +# ICG_GRAPH -- Graph data and fit. + +procedure icg_graphd (ic, gp, gt, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointers +pointer cv # Curfit pointer +double x[npts] # Independent variable +double y[npts] # Dependent variable +double wts[npts] # Weights +int npts # Number of points + +pointer xout, yout +real size + +begin + call malloc (xout, npts, TY_DOUBLE) + call malloc (yout, npts, TY_DOUBLE) + call icg_axesd (ic, gt, cv, 1, x, y, Memd[xout], npts) + call icg_axesd (ic, gt, cv, 2, x, y, Memd[yout], npts) + call icg_paramsd (ic, cv, x, y, wts, npts, gt) + + call icg_g1d (ic, gp, gt, Memd[xout], Memd[yout], wts, npts) + + # Symbol size for averaged ranges. + size = abs(IC_NAVERAGE(ic) * (Memd[xout+npts-1] - Memd[xout]) / + float(npts)) + + if (npts != IC_NFIT(ic)) { + if ((abs (IC_NAVERAGE(ic)) > 1) || (IC_NREJECT(ic) > 0)) { + call realloc (xout, IC_NFIT(ic), TY_DOUBLE) + call realloc (yout, IC_NFIT(ic), TY_DOUBLE) + call icg_axesd (ic, gt, cv, 1, Memd[IC_XFIT(ic)], + Memd[IC_YFIT(ic)], Memd[xout], IC_NFIT(ic)) + call icg_axesd (ic, gt, cv, 2, Memd[IC_XFIT(ic)], + Memd[IC_YFIT(ic)], Memd[yout], IC_NFIT(ic)) + call icg_g2d (ic, gp, gt, Memd[xout], Memd[yout], + IC_NFIT(ic), size) + } + + } else if (IC_NREJECT(ic) > 0) + call icg_g2d (ic, gp, gt, Memd[xout], Memd[yout], npts, size) + + call icg_gfd (ic, gp, gt, cv, max (npts, NGRAPH)) + + # Mark the the sample regions. + + call icg_sampled (ic, gp, gt, x, npts, 1) + + # Send the wcs to the gui. + call ic_gui (ic, "wcs") + + call mfree (xout, TY_DOUBLE) + call mfree (yout, TY_DOUBLE) +end + +procedure icg_g1d (ic, gp, gt, x, y, wts, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +double x[npts] # Ordinates +double y[npts] # Abscissas +double wts[npts] # Weights +int npts # Number of points + +int i +pointer sp, xr, yr, xr1, yr1, gt1 + +begin + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (xr1, 2, TY_REAL) + call salloc (yr1, 2, TY_REAL) + call achtdr (x, Memr[xr], npts) + call achtdr (y, Memr[yr], npts) + + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "cross") + + if (IC_OVERPLOT(ic) == NO) { + # Start a new plot. + + call gclear (gp) + + # Set the graph scale and axes. + + call gascale (gp, Memr[xr], npts, 1) + call gascale (gp, Memr[yr], npts, 2) + call gt_swind (gp, gt) + call gt_labax (gp, gt) + } + + if (IC_OVERPLOT(ic) == NO) { + Memr[xr1] = Memr[xr] + Memr[yr1] = Memr[yr] + do i = 1, npts { + if (wts[i] == 0.) { + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } else { + Memr[xr1+1] = Memr[xr+i-1] + Memr[yr1+1] = Memr[yr+i-1] + call gt_plot (gp, gt, Memr[xr1], Memr[yr1], 2) + Memr[xr1] = Memr[xr1+1] + Memr[yr1] = Memr[yr1+1] + } + } + } + + # Reset status flags. + + IC_OVERPLOT(ic) = NO + + call sfree (sp) + call gt_free (gt1) +end + +procedure icg_g2d (ic, gp, gt, x, y, npts, size) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +double x[npts], y[npts] # Data points +int npts # Number of data points +real size # Symbol size + +int i +pointer sp, xr, yr, gt1 + +begin + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call achtdr (x, Memr[xr], npts) + call achtdr (y, Memr[yr], npts) + + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + + # Mark the sample points. + + if (abs (IC_NAVERAGE(ic)) > 1) { + call gt_sets (gt1, GTMARK, "plus") + call gt_setr (gt1, GTXSIZE, -size) + call gt_setr (gt1, GTYSIZE, 1.) + call gt_plot (gp, gt1, Memr[xr], Memr[yr], npts) + } + + # Mark the rejected points. + + if (IC_NREJECT(ic) > 0 && IC_MARKREJ(ic) == YES) { + call gt_sets (gt1, GTMARK, "diamond") + call gt_setr (gt1, GTXSIZE, MSIZE) + call gt_setr (gt1, GTYSIZE, MSIZE) + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } + } + + call gt_free (gt1) + call sfree (sp) +end + +procedure icg_gfd (ic, gp, gt, cv, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOL pointer +pointer cv # CURFIT pointer +int npts # Number of points to plot + +pointer sp, xr, yr, x, y, xo, yo, gt1 +int i +double dx + +begin + if (IC_FITERROR(ic) == YES) + return + + call smark (sp) + + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (x, npts, TY_DOUBLE) + call salloc (y, npts, TY_DOUBLE) + call salloc (xo, npts, TY_DOUBLE) + call salloc (yo, npts, TY_DOUBLE) + + # Generate vector of independent variable values + dx = (IC_XMAX(ic) - IC_XMIN(ic)) / (npts - 1) + do i = 1, npts + Memd[x+i-1] = IC_XMIN(ic) + (i-1) * dx + + # Calculate vector of fit values. + call dcvvector (cv, Memd[x], Memd[y], npts) + + # Convert to user function or transpose axes. Change type to reals + # for plotting. + call icg_axesd (ic, gt, cv, 1, Memd[x], Memd[y], Memd[xo], npts) + call icg_axesd (ic, gt, cv, 2, Memd[x], Memd[y], Memd[yo], npts) + call achtdr (Memd[xo], Memr[xr], npts) + call achtdr (Memd[yo], Memr[yr], npts) + + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "line") + call gt_seti (gt1, GTLINE, GL_DASHED) + call gt_seti (gt1, GTCOLOR, max (0, min (9, IC_COLOR(ic)))) + call gt_plot (gp, gt1, Memr[xr], Memr[yr], npts) + call gt_free (gt1) + + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icggraphr.x b/pkg/xtools/icfit/icggraphr.x new file mode 100644 index 00000000..ac2a3f2c --- /dev/null +++ b/pkg/xtools/icfit/icggraphr.x @@ -0,0 +1,226 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <pkg/gtools.h> +include "names.h" +include "icfit.h" + +define NGRAPH 100 # Number of fit points to graph +define MSIZE 2. # Mark size + +# ICG_GRAPH -- Graph data and fit. + +procedure icg_graphr (ic, gp, gt, cv, x, y, wts, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointers +pointer cv # Curfit pointer +real x[npts] # Independent variable +real y[npts] # Dependent variable +real wts[npts] # Weights +int npts # Number of points + +pointer xout, yout +real size + +begin + call malloc (xout, npts, TY_REAL) + call malloc (yout, npts, TY_REAL) + call icg_axesr (ic, gt, cv, 1, x, y, Memr[xout], npts) + call icg_axesr (ic, gt, cv, 2, x, y, Memr[yout], npts) + call icg_paramsr (ic, cv, x, y, wts, npts, gt) + + call icg_g1r (ic, gp, gt, Memr[xout], Memr[yout], wts, npts) + + # Symbol size for averaged ranges. + size = abs(IC_NAVERAGE(ic) * (Memr[xout+npts-1] - Memr[xout]) / + float(npts)) + + if (npts != IC_NFIT(ic)) { + if ((abs (IC_NAVERAGE(ic)) > 1) || (IC_NREJECT(ic) > 0)) { + call realloc (xout, IC_NFIT(ic), TY_REAL) + call realloc (yout, IC_NFIT(ic), TY_REAL) + call icg_axesr (ic, gt, cv, 1, Memr[IC_XFIT(ic)], + Memr[IC_YFIT(ic)], Memr[xout], IC_NFIT(ic)) + call icg_axesr (ic, gt, cv, 2, Memr[IC_XFIT(ic)], + Memr[IC_YFIT(ic)], Memr[yout], IC_NFIT(ic)) + call icg_g2r (ic, gp, gt, Memr[xout], Memr[yout], + IC_NFIT(ic), size) + } + + } else if (IC_NREJECT(ic) > 0) + call icg_g2r (ic, gp, gt, Memr[xout], Memr[yout], npts, size) + + call icg_gfr (ic, gp, gt, cv, max (npts, NGRAPH)) + + # Mark the the sample regions. + + call icg_sampler (ic, gp, gt, x, npts, 1) + + # Send the wcs to the gui. + call ic_gui (ic, "wcs") + + call mfree (xout, TY_REAL) + call mfree (yout, TY_REAL) +end + +procedure icg_g1r (ic, gp, gt, x, y, wts, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +real x[npts] # Ordinates +real y[npts] # Abscissas +real wts[npts] # Weights +int npts # Number of points + +int i +pointer sp, xr, yr, xr1, yr1, gt1 + +begin + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (xr1, 2, TY_REAL) + call salloc (yr1, 2, TY_REAL) + call achtrr (x, Memr[xr], npts) + call achtrr (y, Memr[yr], npts) + + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "cross") + + if (IC_OVERPLOT(ic) == NO) { + # Start a new plot. + + call gclear (gp) + + # Set the graph scale and axes. + + call gascale (gp, Memr[xr], npts, 1) + call gascale (gp, Memr[yr], npts, 2) + call gt_swind (gp, gt) + call gt_labax (gp, gt) + } + + if (IC_OVERPLOT(ic) == NO) { + Memr[xr1] = Memr[xr] + Memr[yr1] = Memr[yr] + do i = 1, npts { + if (wts[i] == 0.) { + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } else { + Memr[xr1+1] = Memr[xr+i-1] + Memr[yr1+1] = Memr[yr+i-1] + call gt_plot (gp, gt, Memr[xr1], Memr[yr1], 2) + Memr[xr1] = Memr[xr1+1] + Memr[yr1] = Memr[yr1+1] + } + } + } + + # Reset status flags. + + IC_OVERPLOT(ic) = NO + + call sfree (sp) + call gt_free (gt1) +end + +procedure icg_g2r (ic, gp, gt, x, y, npts, size) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +real x[npts], y[npts] # Data points +int npts # Number of data points +real size # Symbol size + +int i +pointer sp, xr, yr, gt1 + +begin + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call achtrr (x, Memr[xr], npts) + call achtrr (y, Memr[yr], npts) + + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + + # Mark the sample points. + + if (abs (IC_NAVERAGE(ic)) > 1) { + call gt_sets (gt1, GTMARK, "plus") + call gt_setr (gt1, GTXSIZE, -size) + call gt_setr (gt1, GTYSIZE, 1.) + call gt_plot (gp, gt1, Memr[xr], Memr[yr], npts) + } + + # Mark the rejected points. + + if (IC_NREJECT(ic) > 0 && IC_MARKREJ(ic) == YES) { + call gt_sets (gt1, GTMARK, "diamond") + call gt_setr (gt1, GTXSIZE, MSIZE) + call gt_setr (gt1, GTYSIZE, MSIZE) + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } + } + + call gt_free (gt1) + call sfree (sp) +end + +procedure icg_gfr (ic, gp, gt, cv, npts) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOL pointer +pointer cv # CURFIT pointer +int npts # Number of points to plot + +pointer sp, xr, yr, x, y, xo, yo, gt1 +int i +real dx + +begin + if (IC_FITERROR(ic) == YES) + return + + call smark (sp) + + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (x, npts, TY_REAL) + call salloc (y, npts, TY_REAL) + call salloc (xo, npts, TY_REAL) + call salloc (yo, npts, TY_REAL) + + # Generate vector of independent variable values + dx = (IC_XMAX(ic) - IC_XMIN(ic)) / (npts - 1) + do i = 1, npts + Memr[x+i-1] = IC_XMIN(ic) + (i-1) * dx + + # Calculate vector of fit values. + call rcvvector (cv, Memr[x], Memr[y], npts) + + # Convert to user function or transpose axes. Change type to reals + # for plotting. + call icg_axesr (ic, gt, cv, 1, Memr[x], Memr[y], Memr[xo], npts) + call icg_axesr (ic, gt, cv, 2, Memr[x], Memr[y], Memr[yo], npts) + call achtrr (Memr[xo], Memr[xr], npts) + call achtrr (Memr[yo], Memr[yr], npts) + + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "line") + call gt_seti (gt1, GTLINE, GL_DASHED) + call gt_seti (gt1, GTCOLOR, max (0, min (9, IC_COLOR(ic)))) + call gt_plot (gp, gt1, Memr[xr], Memr[yr], npts) + call gt_free (gt1) + + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgnearest.gx b/pkg/xtools/icfit/icgnearest.gx new file mode 100644 index 00000000..d3165940 --- /dev/null +++ b/pkg/xtools/icfit/icgnearest.gx @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <pkg/gtools.h> +include "icfit.h" + +# ICG_NEAREST -- Find the nearest point to the cursor and return the index. +# The nearest point to the cursor in NDC coordinates is determined. +# The cursor is moved to the nearest point selected. + +int procedure icg_nearest$t (ic, gp, gt, cv, x, y, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +PIXEL x[npts], y[npts] # Data points +int npts # Number of points +real wx, wy # Cursor position + +int pt +pointer sp, xout, yout + +int icg_n$t(), gt_geti() + +begin + call smark (sp) + call salloc (xout, npts, TY_PIXEL) + call salloc (yout, npts, TY_PIXEL) + call icg_axes$t (ic, gt, cv, 1, x, y, Mem$t[xout], npts) + call icg_axes$t (ic, gt, cv, 2, x, y, Mem$t[yout], npts) + if (gt_geti (gt, GTTRANSPOSE) == NO) + pt = icg_n$t (gp, Mem$t[xout], Mem$t[yout], npts, wx, wy) + else + pt = icg_n$t (gp, Mem$t[yout], Mem$t[xout], npts, wy, wx) + call sfree (sp) + + return (pt) +end + +int procedure icg_n$t (gp, x, y, npts, wx, wy) + +pointer gp # GIO pointer +PIXEL x[npts], y[npts] # Data points +int npts # Number of points +real wx, wy # Cursor position + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point. + + r2min = MAX_REAL + do i = 1, npts { + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Move the cursor to the selected point and return the index. + + if (j != 0) + call gscur (gp, real (x[j]), real (y[j])) + + return (j) +end diff --git a/pkg/xtools/icfit/icgnearestd.x b/pkg/xtools/icfit/icgnearestd.x new file mode 100644 index 00000000..4011f95c --- /dev/null +++ b/pkg/xtools/icfit/icgnearestd.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <pkg/gtools.h> +include "icfit.h" + +# ICG_NEAREST -- Find the nearest point to the cursor and return the index. +# The nearest point to the cursor in NDC coordinates is determined. +# The cursor is moved to the nearest point selected. + +int procedure icg_nearestd (ic, gp, gt, cv, x, y, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +double x[npts], y[npts] # Data points +int npts # Number of points +real wx, wy # Cursor position + +int pt +pointer sp, xout, yout + +int icg_nd(), gt_geti() + +begin + call smark (sp) + call salloc (xout, npts, TY_DOUBLE) + call salloc (yout, npts, TY_DOUBLE) + call icg_axesd (ic, gt, cv, 1, x, y, Memd[xout], npts) + call icg_axesd (ic, gt, cv, 2, x, y, Memd[yout], npts) + if (gt_geti (gt, GTTRANSPOSE) == NO) + pt = icg_nd (gp, Memd[xout], Memd[yout], npts, wx, wy) + else + pt = icg_nd (gp, Memd[yout], Memd[xout], npts, wy, wx) + call sfree (sp) + + return (pt) +end + +int procedure icg_nd (gp, x, y, npts, wx, wy) + +pointer gp # GIO pointer +double x[npts], y[npts] # Data points +int npts # Number of points +real wx, wy # Cursor position + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point. + + r2min = MAX_REAL + do i = 1, npts { + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Move the cursor to the selected point and return the index. + + if (j != 0) + call gscur (gp, real (x[j]), real (y[j])) + + return (j) +end diff --git a/pkg/xtools/icfit/icgnearestr.x b/pkg/xtools/icfit/icgnearestr.x new file mode 100644 index 00000000..41363103 --- /dev/null +++ b/pkg/xtools/icfit/icgnearestr.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <pkg/gtools.h> +include "icfit.h" + +# ICG_NEAREST -- Find the nearest point to the cursor and return the index. +# The nearest point to the cursor in NDC coordinates is determined. +# The cursor is moved to the nearest point selected. + +int procedure icg_nearestr (ic, gp, gt, cv, x, y, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +real x[npts], y[npts] # Data points +int npts # Number of points +real wx, wy # Cursor position + +int pt +pointer sp, xout, yout + +int icg_nr(), gt_geti() + +begin + call smark (sp) + call salloc (xout, npts, TY_REAL) + call salloc (yout, npts, TY_REAL) + call icg_axesr (ic, gt, cv, 1, x, y, Memr[xout], npts) + call icg_axesr (ic, gt, cv, 2, x, y, Memr[yout], npts) + if (gt_geti (gt, GTTRANSPOSE) == NO) + pt = icg_nr (gp, Memr[xout], Memr[yout], npts, wx, wy) + else + pt = icg_nr (gp, Memr[yout], Memr[xout], npts, wy, wx) + call sfree (sp) + + return (pt) +end + +int procedure icg_nr (gp, x, y, npts, wx, wy) + +pointer gp # GIO pointer +real x[npts], y[npts] # Data points +int npts # Number of points +real wx, wy # Cursor position + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point. + + r2min = MAX_REAL + do i = 1, npts { + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Move the cursor to the selected point and return the index. + + if (j != 0) + call gscur (gp, real (x[j]), real (y[j])) + + return (j) +end diff --git a/pkg/xtools/icfit/icgparams.gx b/pkg/xtools/icfit/icgparams.gx new file mode 100644 index 00000000..c63657e3 --- /dev/null +++ b/pkg/xtools/icfit/icgparams.gx @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/gtools.h> +include "icfit.h" +include "names.h" + +# ICG_PARAMS -- Set parameter string. + +procedure icg_params$t (ic, cv, x, y, wts, npts, gt) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +PIXEL x[ARB] # Ordinates +PIXEL y[ARB] # Abscissas +PIXEL wts[ARB] # Weights +int npts # Number of data points +pointer gt # GTOOLS pointer + +int i, n, deleted +PIXEL rms +pointer sp, fit, wts1, str, params + +PIXEL ic_rms$t() + +begin + call smark (sp) + + n = IC_NFIT(ic) + deleted = 0 + rms = INDEF + + if (n == npts) { + # Allocate memory for the fit. + + call salloc (fit, n, TY_PIXEL) + call salloc (wts1, n, TY_PIXEL) + + # Eliminate rejected points and count deleted points. + + call amov$t (wts, Mem$t[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Mem$t[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Set the fit and compute the RMS error. + + if (IC_FITERROR(ic) == NO) { + call $tcvvector (cv, x, Mem$t[fit], n) + rms = ic_rms$t (x, y, Mem$t[fit], Mem$t[wts1], n) + } else + rms = INDEF + } else if (n > 0) { + # Allocate memory for the fit. + + call salloc (fit, n, TY_PIXEL) + call salloc (wts1, n, TY_PIXEL) + + # Eliminate rejected points and count deleted points. + + call amov$t (Mem$t[IC_WTSFIT(ic)], Mem$t[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Mem$t[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Set the fit and compute the rms error. + + if (IC_FITERROR(ic) == NO) { + call $tcvvector (cv, Mem$t[IC_XFIT(ic)], Mem$t[fit], n) + rms = ic_rms$t (Mem$t[IC_XFIT(ic)], Mem$t[IC_YFIT(ic)], + Mem$t[fit], Mem$t[wts1], n) + } else + rms = INDEF + } + + # Print the parameters and errors. + + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (params, 2*SZ_LINE, TY_CHAR) + + call sprintf (Memc[str], SZ_LINE, + "func=%s, order=%d, low_rej=%r, high_rej=%r, niterate=%d, grow=%r") + call ic_gstr (ic, "function", Memc[params], 2*SZ_LINE) + call pargstr (Memc[params]) + call pargi (IC_ORDER(ic)) + call pargr (IC_LOW(ic)) + call pargr (IC_HIGH(ic)) + call pargi (IC_NITERATE(ic)) + call pargr (IC_GROW(ic)) + call sprintf (Memc[params], 2*SZ_LINE, + "%s\ntotal=%d, sample=%d, rejected=%d, deleted=%d, RMS=%7.4g") + call pargstr (Memc[str]) + call pargi (npts) + call pargi (n) + call pargi (IC_NREJECT(ic)) + call pargi (deleted) + call parg$t (rms) + call gt_sets (gt, GTPARAMS, Memc[params]) + + # Free allocated memory. + + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgparamsd.x b/pkg/xtools/icfit/icgparamsd.x new file mode 100644 index 00000000..de9397ab --- /dev/null +++ b/pkg/xtools/icfit/icgparamsd.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/gtools.h> +include "icfit.h" +include "names.h" + +# ICG_PARAMS -- Set parameter string. + +procedure icg_paramsd (ic, cv, x, y, wts, npts, gt) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +double x[ARB] # Ordinates +double y[ARB] # Abscissas +double wts[ARB] # Weights +int npts # Number of data points +pointer gt # GTOOLS pointer + +int i, n, deleted +double rms +pointer sp, fit, wts1, str, params + +double ic_rmsd() + +begin + call smark (sp) + + n = IC_NFIT(ic) + deleted = 0 + rms = INDEFD + + if (n == npts) { + # Allocate memory for the fit. + + call salloc (fit, n, TY_DOUBLE) + call salloc (wts1, n, TY_DOUBLE) + + # Eliminate rejected points and count deleted points. + + call amovd (wts, Memd[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memd[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Set the fit and compute the RMS error. + + if (IC_FITERROR(ic) == NO) { + call dcvvector (cv, x, Memd[fit], n) + rms = ic_rmsd (x, y, Memd[fit], Memd[wts1], n) + } else + rms = INDEFD + } else if (n > 0) { + # Allocate memory for the fit. + + call salloc (fit, n, TY_DOUBLE) + call salloc (wts1, n, TY_DOUBLE) + + # Eliminate rejected points and count deleted points. + + call amovd (Memd[IC_WTSFIT(ic)], Memd[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memd[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Set the fit and compute the rms error. + + if (IC_FITERROR(ic) == NO) { + call dcvvector (cv, Memd[IC_XFIT(ic)], Memd[fit], n) + rms = ic_rmsd (Memd[IC_XFIT(ic)], Memd[IC_YFIT(ic)], + Memd[fit], Memd[wts1], n) + } else + rms = INDEFD + } + + # Print the parameters and errors. + + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (params, 2*SZ_LINE, TY_CHAR) + + call sprintf (Memc[str], SZ_LINE, + "func=%s, order=%d, low_rej=%r, high_rej=%r, niterate=%d, grow=%r") + call ic_gstr (ic, "function", Memc[params], 2*SZ_LINE) + call pargstr (Memc[params]) + call pargi (IC_ORDER(ic)) + call pargr (IC_LOW(ic)) + call pargr (IC_HIGH(ic)) + call pargi (IC_NITERATE(ic)) + call pargr (IC_GROW(ic)) + call sprintf (Memc[params], 2*SZ_LINE, + "%s\ntotal=%d, sample=%d, rejected=%d, deleted=%d, RMS=%7.4g") + call pargstr (Memc[str]) + call pargi (npts) + call pargi (n) + call pargi (IC_NREJECT(ic)) + call pargi (deleted) + call pargd (rms) + call gt_sets (gt, GTPARAMS, Memc[params]) + + # Free allocated memory. + + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgparamsr.x b/pkg/xtools/icfit/icgparamsr.x new file mode 100644 index 00000000..a1c898de --- /dev/null +++ b/pkg/xtools/icfit/icgparamsr.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/gtools.h> +include "icfit.h" +include "names.h" + +# ICG_PARAMS -- Set parameter string. + +procedure icg_paramsr (ic, cv, x, y, wts, npts, gt) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +real x[ARB] # Ordinates +real y[ARB] # Abscissas +real wts[ARB] # Weights +int npts # Number of data points +pointer gt # GTOOLS pointer + +int i, n, deleted +real rms +pointer sp, fit, wts1, str, params + +real ic_rmsr() + +begin + call smark (sp) + + n = IC_NFIT(ic) + deleted = 0 + rms = INDEFR + + if (n == npts) { + # Allocate memory for the fit. + + call salloc (fit, n, TY_REAL) + call salloc (wts1, n, TY_REAL) + + # Eliminate rejected points and count deleted points. + + call amovr (wts, Memr[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memr[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Set the fit and compute the RMS error. + + if (IC_FITERROR(ic) == NO) { + call rcvvector (cv, x, Memr[fit], n) + rms = ic_rmsr (x, y, Memr[fit], Memr[wts1], n) + } else + rms = INDEFR + } else if (n > 0) { + # Allocate memory for the fit. + + call salloc (fit, n, TY_REAL) + call salloc (wts1, n, TY_REAL) + + # Eliminate rejected points and count deleted points. + + call amovr (Memr[IC_WTSFIT(ic)], Memr[wts1], n) + if (IC_NREJECT(ic) > 0) { + do i = 1, npts { + if (Memi[IC_REJPTS(ic)+i-1] == YES) + Memr[wts1+i-1] = 0. + } + } + deleted = 0 + do i = 1, n { + if (wts[i] == 0.) + deleted = deleted + 1 + } + + # Set the fit and compute the rms error. + + if (IC_FITERROR(ic) == NO) { + call rcvvector (cv, Memr[IC_XFIT(ic)], Memr[fit], n) + rms = ic_rmsr (Memr[IC_XFIT(ic)], Memr[IC_YFIT(ic)], + Memr[fit], Memr[wts1], n) + } else + rms = INDEFR + } + + # Print the parameters and errors. + + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (params, 2*SZ_LINE, TY_CHAR) + + call sprintf (Memc[str], SZ_LINE, + "func=%s, order=%d, low_rej=%r, high_rej=%r, niterate=%d, grow=%r") + call ic_gstr (ic, "function", Memc[params], 2*SZ_LINE) + call pargstr (Memc[params]) + call pargi (IC_ORDER(ic)) + call pargr (IC_LOW(ic)) + call pargr (IC_HIGH(ic)) + call pargi (IC_NITERATE(ic)) + call pargr (IC_GROW(ic)) + call sprintf (Memc[params], 2*SZ_LINE, + "%s\ntotal=%d, sample=%d, rejected=%d, deleted=%d, RMS=%7.4g") + call pargstr (Memc[str]) + call pargi (npts) + call pargi (n) + call pargi (IC_NREJECT(ic)) + call pargi (deleted) + call pargr (rms) + call gt_sets (gt, GTPARAMS, Memc[params]) + + # Free allocated memory. + + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgsample.gx b/pkg/xtools/icfit/icgsample.gx new file mode 100644 index 00000000..84d5216a --- /dev/null +++ b/pkg/xtools/icfit/icgsample.gx @@ -0,0 +1,226 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <mach.h> +include <pkg/rg.h> +include <pkg/gtools.h> +include "icfit.h" + +# ICG_SAMPLE -- Mark sample. + +procedure icg_sample$t (ic, gp, gt, x, npts, pltype) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +PIXEL x[npts] # Ordinates of graph +int npts # Number of data points +int pltype # Plot line type + +pointer rg +int i, axis, pltype1 +real xl, xr, yb, yt, dy +real x1, x2, y1, y2, y3 + +int gstati(), stridxs(), gt_geti() +pointer rg_xranges$t() + +begin + if (stridxs ("*", Memc[IC_SAMPLE(ic)]) > 0) + return + + # Find axis along which the independent data is plotted. + if (IC_AXES(ic,IC_GKEY(ic),1) == 'x') + axis = 1 + else if (IC_AXES(ic,IC_GKEY(ic),2) == 'x') + axis = 2 + else + return + + if (gt_geti (gt, GTTRANSPOSE) == YES) + axis = mod (axis, 2) + 1 + + pltype1 = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, pltype) + rg = rg_xranges$t (Memc[IC_SAMPLE(ic)], x, npts) + + switch (axis) { + case 1: + call ggwind (gp, xl, xr, yb, yt) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if ((x1 > xl) && (x1 < xr)) + call gline (gp, x1, y1, x1, y2) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, x2, y1, x2, y2) + call gline (gp, x1, y3, x2, y3) + } + case 2: + call ggwind (gp, yb, yt, xl, xr) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if ((x1 > xl) && (x1 < xr)) + call gline (gp, y1, x1, y2, x1) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, y1, x2, y2, x2) + call gline (gp, y3, x1, y3, x2) + } + } + + call gseti (gp, G_PLTYPE, pltype1) + call rg_free (rg) +end + + +# ICG_DSAMPLE -- Delete sample region. + +procedure icg_dsample$t (wx, wy, ic, gp, gt, x, npts) + +real wx, wy # Region to be deleted +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +PIXEL x[npts] # Ordinates of graph +int npts # Number of data points + +pointer sp, str, rg +int i, j, axis, pltype1 +real w, diff +real xl, xr, yb, yt, dy +real x1, x2, y1, y2, y3 + +int gstati(), stridxs(), gt_geti() +pointer rg_xranges$t() + +begin + if (stridxs ("*", Memc[IC_SAMPLE(ic)]) > 0) + return + + # Find axis along which the independent data is plotted. + if (IC_AXES(ic,IC_GKEY(ic),1) == 'x') + axis = 1 + else if (IC_AXES(ic,IC_GKEY(ic),2) == 'x') + axis = 2 + else + return + + if (gt_geti (gt, GTTRANSPOSE) == YES) + axis = mod (axis, 2) + 1 + + # Initialize + pltype1 = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, 0) + rg = rg_xranges$t (Memc[IC_SAMPLE(ic)], x, npts) + + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + Memc[IC_SAMPLE(ic)] = EOS + + # Find nearest sample region + if (axis == 1) + w = wx + else + w = wy + + j = 1 + diff = MAX_REAL + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if (w < x1) { + if (x1 - w < diff) { + diff = x1 - wx + j = i + } + } else if (wx > x2) { + if (wx - x2 < diff) { + diff = x1 - wx + j = i + } + } else { + diff = 0. + j = i + } + } + + # Erase sample region and reset sample string + switch (axis) { + case 1: + call ggwind (gp, xl, xr, yb, yt) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if (i != j) { + if (x1 == int(x1) && x2 == int(x2)) + call sprintf (Memc[str], SZ_FNAME, " %d:%d") + else + call sprintf (Memc[str], SZ_FNAME, " %g:%g") + call pargr (x1) + call pargr (x2) + call strcat (Memc[str], Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + } else { + if ((x1 > xl) && (x1 < xr)) + call gline (gp, x1, y1, x1, y2) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, x2, y1, x2, y2) + call gline (gp, x1, y3, x2, y3) + IC_NEWX(ic) = YES + } + } + case 2: + call ggwind (gp, yb, yt, xl, xr) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if (i != j) { + if (x1 == int(x1) && x2 == int(x2)) + call sprintf (Memc[str], SZ_FNAME, " %d:%d") + else + call sprintf (Memc[str], SZ_FNAME, " %g:%g") + call pargr (x1) + call pargr (x2) + call strcat (Memc[str], Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + } else { + if ((x1 > xl) && (x1 < xr)) + call gline (gp, y1, x1, y2, x1) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, y1, x2, y2, x2) + call gline (gp, y3, x1, y3, x2) + IC_NEWX(ic) = YES + } + } + } + + if (Memc[IC_SAMPLE(ic)] == EOS) + call strcat ("*", Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + + call gseti (gp, G_PLTYPE, pltype1) + call rg_free (rg) + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgsampled.x b/pkg/xtools/icfit/icgsampled.x new file mode 100644 index 00000000..314dfc33 --- /dev/null +++ b/pkg/xtools/icfit/icgsampled.x @@ -0,0 +1,226 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <mach.h> +include <pkg/rg.h> +include <pkg/gtools.h> +include "icfit.h" + +# ICG_SAMPLE -- Mark sample. + +procedure icg_sampled (ic, gp, gt, x, npts, pltype) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +double x[npts] # Ordinates of graph +int npts # Number of data points +int pltype # Plot line type + +pointer rg +int i, axis, pltype1 +real xl, xr, yb, yt, dy +real x1, x2, y1, y2, y3 + +int gstati(), stridxs(), gt_geti() +pointer rg_xrangesd() + +begin + if (stridxs ("*", Memc[IC_SAMPLE(ic)]) > 0) + return + + # Find axis along which the independent data is plotted. + if (IC_AXES(ic,IC_GKEY(ic),1) == 'x') + axis = 1 + else if (IC_AXES(ic,IC_GKEY(ic),2) == 'x') + axis = 2 + else + return + + if (gt_geti (gt, GTTRANSPOSE) == YES) + axis = mod (axis, 2) + 1 + + pltype1 = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, pltype) + rg = rg_xrangesd (Memc[IC_SAMPLE(ic)], x, npts) + + switch (axis) { + case 1: + call ggwind (gp, xl, xr, yb, yt) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if ((x1 > xl) && (x1 < xr)) + call gline (gp, x1, y1, x1, y2) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, x2, y1, x2, y2) + call gline (gp, x1, y3, x2, y3) + } + case 2: + call ggwind (gp, yb, yt, xl, xr) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if ((x1 > xl) && (x1 < xr)) + call gline (gp, y1, x1, y2, x1) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, y1, x2, y2, x2) + call gline (gp, y3, x1, y3, x2) + } + } + + call gseti (gp, G_PLTYPE, pltype1) + call rg_free (rg) +end + + +# ICG_DSAMPLE -- Delete sample region. + +procedure icg_dsampled (wx, wy, ic, gp, gt, x, npts) + +real wx, wy # Region to be deleted +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +double x[npts] # Ordinates of graph +int npts # Number of data points + +pointer sp, str, rg +int i, j, axis, pltype1 +real w, diff +real xl, xr, yb, yt, dy +real x1, x2, y1, y2, y3 + +int gstati(), stridxs(), gt_geti() +pointer rg_xrangesd() + +begin + if (stridxs ("*", Memc[IC_SAMPLE(ic)]) > 0) + return + + # Find axis along which the independent data is plotted. + if (IC_AXES(ic,IC_GKEY(ic),1) == 'x') + axis = 1 + else if (IC_AXES(ic,IC_GKEY(ic),2) == 'x') + axis = 2 + else + return + + if (gt_geti (gt, GTTRANSPOSE) == YES) + axis = mod (axis, 2) + 1 + + # Initialize + pltype1 = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, 0) + rg = rg_xrangesd (Memc[IC_SAMPLE(ic)], x, npts) + + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + Memc[IC_SAMPLE(ic)] = EOS + + # Find nearest sample region + if (axis == 1) + w = wx + else + w = wy + + j = 1 + diff = MAX_REAL + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if (w < x1) { + if (x1 - w < diff) { + diff = x1 - wx + j = i + } + } else if (wx > x2) { + if (wx - x2 < diff) { + diff = x1 - wx + j = i + } + } else { + diff = 0. + j = i + } + } + + # Erase sample region and reset sample string + switch (axis) { + case 1: + call ggwind (gp, xl, xr, yb, yt) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if (i != j) { + if (x1 == int(x1) && x2 == int(x2)) + call sprintf (Memc[str], SZ_FNAME, " %d:%d") + else + call sprintf (Memc[str], SZ_FNAME, " %g:%g") + call pargr (x1) + call pargr (x2) + call strcat (Memc[str], Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + } else { + if ((x1 > xl) && (x1 < xr)) + call gline (gp, x1, y1, x1, y2) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, x2, y1, x2, y2) + call gline (gp, x1, y3, x2, y3) + IC_NEWX(ic) = YES + } + } + case 2: + call ggwind (gp, yb, yt, xl, xr) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if (i != j) { + if (x1 == int(x1) && x2 == int(x2)) + call sprintf (Memc[str], SZ_FNAME, " %d:%d") + else + call sprintf (Memc[str], SZ_FNAME, " %g:%g") + call pargr (x1) + call pargr (x2) + call strcat (Memc[str], Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + } else { + if ((x1 > xl) && (x1 < xr)) + call gline (gp, y1, x1, y2, x1) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, y1, x2, y2, x2) + call gline (gp, y3, x1, y3, x2) + IC_NEWX(ic) = YES + } + } + } + + if (Memc[IC_SAMPLE(ic)] == EOS) + call strcat ("*", Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + + call gseti (gp, G_PLTYPE, pltype1) + call rg_free (rg) + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgsampler.x b/pkg/xtools/icfit/icgsampler.x new file mode 100644 index 00000000..2310cbb8 --- /dev/null +++ b/pkg/xtools/icfit/icgsampler.x @@ -0,0 +1,226 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <mach.h> +include <pkg/rg.h> +include <pkg/gtools.h> +include "icfit.h" + +# ICG_SAMPLE -- Mark sample. + +procedure icg_sampler (ic, gp, gt, x, npts, pltype) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +real x[npts] # Ordinates of graph +int npts # Number of data points +int pltype # Plot line type + +pointer rg +int i, axis, pltype1 +real xl, xr, yb, yt, dy +real x1, x2, y1, y2, y3 + +int gstati(), stridxs(), gt_geti() +pointer rg_xrangesr() + +begin + if (stridxs ("*", Memc[IC_SAMPLE(ic)]) > 0) + return + + # Find axis along which the independent data is plotted. + if (IC_AXES(ic,IC_GKEY(ic),1) == 'x') + axis = 1 + else if (IC_AXES(ic,IC_GKEY(ic),2) == 'x') + axis = 2 + else + return + + if (gt_geti (gt, GTTRANSPOSE) == YES) + axis = mod (axis, 2) + 1 + + pltype1 = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, pltype) + rg = rg_xrangesr (Memc[IC_SAMPLE(ic)], x, npts) + + switch (axis) { + case 1: + call ggwind (gp, xl, xr, yb, yt) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if ((x1 > xl) && (x1 < xr)) + call gline (gp, x1, y1, x1, y2) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, x2, y1, x2, y2) + call gline (gp, x1, y3, x2, y3) + } + case 2: + call ggwind (gp, yb, yt, xl, xr) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if ((x1 > xl) && (x1 < xr)) + call gline (gp, y1, x1, y2, x1) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, y1, x2, y2, x2) + call gline (gp, y3, x1, y3, x2) + } + } + + call gseti (gp, G_PLTYPE, pltype1) + call rg_free (rg) +end + + +# ICG_DSAMPLE -- Delete sample region. + +procedure icg_dsampler (wx, wy, ic, gp, gt, x, npts) + +real wx, wy # Region to be deleted +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +real x[npts] # Ordinates of graph +int npts # Number of data points + +pointer sp, str, rg +int i, j, axis, pltype1 +real w, diff +real xl, xr, yb, yt, dy +real x1, x2, y1, y2, y3 + +int gstati(), stridxs(), gt_geti() +pointer rg_xrangesr() + +begin + if (stridxs ("*", Memc[IC_SAMPLE(ic)]) > 0) + return + + # Find axis along which the independent data is plotted. + if (IC_AXES(ic,IC_GKEY(ic),1) == 'x') + axis = 1 + else if (IC_AXES(ic,IC_GKEY(ic),2) == 'x') + axis = 2 + else + return + + if (gt_geti (gt, GTTRANSPOSE) == YES) + axis = mod (axis, 2) + 1 + + # Initialize + pltype1 = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, 0) + rg = rg_xrangesr (Memc[IC_SAMPLE(ic)], x, npts) + + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + Memc[IC_SAMPLE(ic)] = EOS + + # Find nearest sample region + if (axis == 1) + w = wx + else + w = wy + + j = 1 + diff = MAX_REAL + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if (w < x1) { + if (x1 - w < diff) { + diff = x1 - wx + j = i + } + } else if (wx > x2) { + if (wx - x2 < diff) { + diff = x1 - wx + j = i + } + } else { + diff = 0. + j = i + } + } + + # Erase sample region and reset sample string + switch (axis) { + case 1: + call ggwind (gp, xl, xr, yb, yt) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if (i != j) { + if (x1 == int(x1) && x2 == int(x2)) + call sprintf (Memc[str], SZ_FNAME, " %d:%d") + else + call sprintf (Memc[str], SZ_FNAME, " %g:%g") + call pargr (x1) + call pargr (x2) + call strcat (Memc[str], Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + } else { + if ((x1 > xl) && (x1 < xr)) + call gline (gp, x1, y1, x1, y2) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, x2, y1, x2, y2) + call gline (gp, x1, y3, x2, y3) + IC_NEWX(ic) = YES + } + } + case 2: + call ggwind (gp, yb, yt, xl, xr) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if (i != j) { + if (x1 == int(x1) && x2 == int(x2)) + call sprintf (Memc[str], SZ_FNAME, " %d:%d") + else + call sprintf (Memc[str], SZ_FNAME, " %g:%g") + call pargr (x1) + call pargr (x2) + call strcat (Memc[str], Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + } else { + if ((x1 > xl) && (x1 < xr)) + call gline (gp, y1, x1, y2, x1) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, y1, x2, y2, x2) + call gline (gp, y3, x1, y3, x2) + IC_NEWX(ic) = YES + } + } + } + + if (Memc[IC_SAMPLE(ic)] == EOS) + call strcat ("*", Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + + call gseti (gp, G_PLTYPE, pltype1) + call rg_free (rg) + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icguaxes.gx b/pkg/xtools/icfit/icguaxes.gx new file mode 100644 index 00000000..1527a10e --- /dev/null +++ b/pkg/xtools/icfit/icguaxes.gx @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ICG_UAXES -- Set user axis + +procedure icg_uaxes$t (key, cv, x, y, z, npts, label, units, maxchars) + +int key # Key for axes +pointer cv # CURFIT pointer +PIXEL x[npts] # Independent variable +PIXEL y[npts] # Dependent variable +PIXEL z[npts] # Output values +int npts # Number of points +char label[maxchars] # Axis label +char units[maxchars] # Axis units +int maxchars # Maximum chars in label + +begin +end diff --git a/pkg/xtools/icfit/icguaxesd.x b/pkg/xtools/icfit/icguaxesd.x new file mode 100644 index 00000000..b787d211 --- /dev/null +++ b/pkg/xtools/icfit/icguaxesd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ICG_UAXES -- Set user axis + +procedure icg_uaxesd (key, cv, x, y, z, npts, label, units, maxchars) + +int key # Key for axes +pointer cv # CURFIT pointer +double x[npts] # Independent variable +double y[npts] # Dependent variable +double z[npts] # Output values +int npts # Number of points +char label[maxchars] # Axis label +char units[maxchars] # Axis units +int maxchars # Maximum chars in label + +begin +end diff --git a/pkg/xtools/icfit/icguaxesr.x b/pkg/xtools/icfit/icguaxesr.x new file mode 100644 index 00000000..deeac3c7 --- /dev/null +++ b/pkg/xtools/icfit/icguaxesr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ICG_UAXES -- Set user axis + +procedure icg_uaxesr (key, cv, x, y, z, npts, label, units, maxchars) + +int key # Key for axes +pointer cv # CURFIT pointer +real x[npts] # Independent variable +real y[npts] # Dependent variable +real z[npts] # Output values +int npts # Number of points +char label[maxchars] # Axis label +char units[maxchars] # Axis units +int maxchars # Maximum chars in label + +begin +end diff --git a/pkg/xtools/icfit/icgui.x b/pkg/xtools/icfit/icgui.x new file mode 100644 index 00000000..9e0fd6e0 --- /dev/null +++ b/pkg/xtools/icfit/icgui.x @@ -0,0 +1,138 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <gio.h> +include "icfit.h" + +define CMDS "|open|close|params|graph|wcs|refit|help|" + +define OPEN 1 # Open GUI and send initial parameters +define CLOSE 2 # Close GUI and send final parameters +define PARAMS 3 # Send new parameters +define GRAPH 4 # Send graph type parameters +define WCS 5 # Send graph wcs parameters +define REFIT 6 # Send refit flag +define HELP 7 # Send help + +# IC_GUI -- GUI interaction. +# +# Note there is currently an interface violation to determine if the graphics +# stream is connected to a GUI. + +procedure ic_gui (ic, cmd) + +pointer ic #I ICFIT pointer +char cmd[ARB] #I Command + +int ncmd, strdic() +real vx1, vx2, vy1, vy2, wx1, wx2, wy1, wy2 +pointer sp, str, msg +bool streq() +errchk ic_help + +begin + if (IC_GP(ic) == NULL) + return + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Scan the command and switch on the first word. + call sscan (cmd) + call gargwrd (Memc[str], SZ_LINE) + ncmd = strdic (Memc[str], Memc[str], SZ_LINE, CMDS) + switch (ncmd) { + case OPEN, CLOSE, PARAMS: + call salloc (msg, SZ_LINE+IC_SZSAMPLE, TY_CHAR) + call ic_gstr (ic, "function", Memc[str], SZ_LINE) + call sprintf (Memc[msg], SZ_LINE+IC_SZSAMPLE, + "%s %s %d \"%s\" %d %d %g %g %g %b") + call pargstr (cmd) + call pargstr (Memc[str]) + call pargi (IC_ORDER(ic)) + call pargstr (Memc[IC_SAMPLE(ic)]) + call pargi (IC_NAVERAGE(ic)) + call pargi (IC_NITERATE(ic)) + call pargr (IC_LOW(ic)) + call pargr (IC_HIGH(ic)) + call pargr (IC_GROW(ic)) + call pargi (IC_MARKREJ(ic)) + if (GP_UIFNAME(IC_GP(ic)) != EOS) + call gmsg (IC_GP(ic), "icfit", Memc[msg]) + + if (GP_UIFNAME(IC_GP(ic)) != EOS) { + if (streq (Memc[IC_HELP(ic)], IC_DEFHELP)) + call strcpy (IC_DEFHTML, Memc[IC_HELP(ic)], SZ_LINE) + } + + case GRAPH: + call sprintf (Memc[str], SZ_LINE, "graph %c %c %c") + call pargi ('h'+IC_GKEY(ic)-1) + call pargi (IC_AXES(ic,IC_GKEY(ic),1)) + call pargi (IC_AXES(ic,IC_GKEY(ic),2)) + if (GP_UIFNAME(IC_GP(ic)) != EOS) + call gmsg (IC_GP(ic), "icfit", Memc[str]) + + case WCS: + call ggview (IC_GP(ic), vx1, vx2, vy1, vy2) + call ggwind (IC_GP(ic), wx1, wx2, wy1, wy2) + call sprintf (Memc[str], SZ_LINE, "wcs %g %g %g %g %g %g %g %g") + call pargr (vx1) + call pargr (vx2) + call pargr (vy1) + call pargr (vy2) + call pargr (wx1) + call pargr (wx2) + call pargr (wy1) + call pargr (wy2) + if (GP_UIFNAME(IC_GP(ic)) != EOS) + call gmsg (IC_GP(ic), "icfit", Memc[str]) + + case REFIT: + if (GP_UIFNAME(IC_GP(ic)) != EOS) + call gmsg (IC_GP(ic), "icrefit", cmd) + + case HELP: + if (GP_UIFNAME(IC_GP(ic)) != EOS) + call ic_help (ic) + else + call gpagefile (IC_GP(ic), Memc[IC_HELP(ic)], IC_PROMPT) + } + + call sfree (sp) +end + + +# IC_HELP - Send help to GUI + +procedure ic_help (ic) + +pointer ic #I ICFIT pointer + +int i, fd, len_str, open(), getline() +pointer line, help +errchk open() + +begin + len_str = 10 * SZ_LINE + call calloc (help, len_str, TY_CHAR) + line = help + + fd = open (Memc[IC_HELP(ic)], READ_ONLY, TEXT_FILE) + while (getline (fd, Memc[line]) != EOF) { + for (; Memc[line]!=EOS; line=line+1) + ; + i = line - help + if (i + SZ_LINE > len_str) { + len_str = len_str + 10 * SZ_LINE + call realloc (help, len_str, TY_CHAR) + line = help + i + } + } + call close (fd) + + # Send results to GUI. + call gmsg (IC_GP(ic), "ichelp", Memc[help]) + + call mfree (help, TY_CHAR) +end diff --git a/pkg/xtools/icfit/icguishow.gx b/pkg/xtools/icfit/icguishow.gx new file mode 100644 index 00000000..30df5f4d --- /dev/null +++ b/pkg/xtools/icfit/icguishow.gx @@ -0,0 +1,86 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <gset.h> +include <gio.h> +include "icfit.h" +include "names.h" + +define CMDS "|show|vshow|xyshow|errors|" + +define SHOW 1 # Show information +define VSHOW 2 # Show verbose information +define XYSHOW 3 # Show points +define ERRORS 4 # Show errors + +# IC_GUISHOW -- GUI show. +# +# Note there is currently an interface violation to determine if the graphics +# stream is connected to a GUI. + +procedure ic_guishow$t (ic, cmd, cv, x, y, wts, npts) + +pointer ic #I ICFIT pointer +char cmd[ARB] #I Command +pointer cv #I CURFIT pointer for error listing +PIXEL x[npts], y[npts], wts[npts] #I Data arrays +int npts #I Number of data points + +int ncmd, deact, fd +pointer sp, str, msg +int strdic(), nscan(), stropen(), open() +errchk stropen, open, ic_fshow, ic_fvshow$t, ic_fxyshow$t, ic_ferrors$t + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Scan the command. + call sscan (cmd) + call gargwrd (Memc[str], SZ_LINE) + ncmd = strdic (Memc[str], Memc[str], SZ_LINE, CMDS) + call gargwrd (Memc[str], SZ_LINE) + + iferr { + # Setup the output. + deact = NO + msg = NULL + + if (nscan() == 1) { + if (GP_UIFNAME(IC_GP(ic)) != EOS) { + call malloc (msg, 100000, TY_CHAR) + fd = stropen (Memc[msg], 100000, WRITE_ONLY) + } else { + fd = open ("STDOUT", APPEND, TEXT_FILE) + call gdeactivate (IC_GP(ic), AW_CLEAR) + deact = YES + } + } else + fd = open (Memc[str], APPEND, TEXT_FILE) + + # Write the results to the output. + switch (ncmd) { + case SHOW: + call ic_fshow (ic, fd) + case VSHOW: + call ic_fvshow$t (ic, cv, x, y, wts, npts, fd) + case XYSHOW: + call ic_fxyshow$t (ic, cv, x, y, wts, npts, fd) + case ERRORS: + call ic_fshow (ic, fd) + call ic_ferrors$t (ic, cv, x, y, wts, npts, fd) + } + + # Flush the output. + call close (fd) + if (msg != NULL) + call gmsg (IC_GP(ic), "icshow", Memc[msg]) + } then + call erract (EA_WARN) + + if (msg != NULL) + call mfree (msg, TY_CHAR) + if (deact == YES) + call greactivate (IC_GP(ic), AW_PAUSE) + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icguishowd.x b/pkg/xtools/icfit/icguishowd.x new file mode 100644 index 00000000..dee7401d --- /dev/null +++ b/pkg/xtools/icfit/icguishowd.x @@ -0,0 +1,86 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <gset.h> +include <gio.h> +include "icfit.h" +include "names.h" + +define CMDS "|show|vshow|xyshow|errors|" + +define SHOW 1 # Show information +define VSHOW 2 # Show verbose information +define XYSHOW 3 # Show points +define ERRORS 4 # Show errors + +# IC_GUISHOW -- GUI show. +# +# Note there is currently an interface violation to determine if the graphics +# stream is connected to a GUI. + +procedure ic_guishowd (ic, cmd, cv, x, y, wts, npts) + +pointer ic #I ICFIT pointer +char cmd[ARB] #I Command +pointer cv #I CURFIT pointer for error listing +double x[npts], y[npts], wts[npts] #I Data arrays +int npts #I Number of data points + +int ncmd, deact, fd +pointer sp, str, msg +int strdic(), nscan(), stropen(), open() +errchk stropen, open, ic_fshow, ic_fvshowd, ic_fxyshowd, ic_ferrorsd + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Scan the command. + call sscan (cmd) + call gargwrd (Memc[str], SZ_LINE) + ncmd = strdic (Memc[str], Memc[str], SZ_LINE, CMDS) + call gargwrd (Memc[str], SZ_LINE) + + iferr { + # Setup the output. + deact = NO + msg = NULL + + if (nscan() == 1) { + if (GP_UIFNAME(IC_GP(ic)) != EOS) { + call malloc (msg, 100000, TY_CHAR) + fd = stropen (Memc[msg], 100000, WRITE_ONLY) + } else { + fd = open ("STDOUT", APPEND, TEXT_FILE) + call gdeactivate (IC_GP(ic), AW_CLEAR) + deact = YES + } + } else + fd = open (Memc[str], APPEND, TEXT_FILE) + + # Write the results to the output. + switch (ncmd) { + case SHOW: + call ic_fshow (ic, fd) + case VSHOW: + call ic_fvshowd (ic, cv, x, y, wts, npts, fd) + case XYSHOW: + call ic_fxyshowd (ic, cv, x, y, wts, npts, fd) + case ERRORS: + call ic_fshow (ic, fd) + call ic_ferrorsd (ic, cv, x, y, wts, npts, fd) + } + + # Flush the output. + call close (fd) + if (msg != NULL) + call gmsg (IC_GP(ic), "icshow", Memc[msg]) + } then + call erract (EA_WARN) + + if (msg != NULL) + call mfree (msg, TY_CHAR) + if (deact == YES) + call greactivate (IC_GP(ic), AW_PAUSE) + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icguishowr.x b/pkg/xtools/icfit/icguishowr.x new file mode 100644 index 00000000..f16a957e --- /dev/null +++ b/pkg/xtools/icfit/icguishowr.x @@ -0,0 +1,86 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <gset.h> +include <gio.h> +include "icfit.h" +include "names.h" + +define CMDS "|show|vshow|xyshow|errors|" + +define SHOW 1 # Show information +define VSHOW 2 # Show verbose information +define XYSHOW 3 # Show points +define ERRORS 4 # Show errors + +# IC_GUISHOW -- GUI show. +# +# Note there is currently an interface violation to determine if the graphics +# stream is connected to a GUI. + +procedure ic_guishowr (ic, cmd, cv, x, y, wts, npts) + +pointer ic #I ICFIT pointer +char cmd[ARB] #I Command +pointer cv #I CURFIT pointer for error listing +real x[npts], y[npts], wts[npts] #I Data arrays +int npts #I Number of data points + +int ncmd, deact, fd +pointer sp, str, msg +int strdic(), nscan(), stropen(), open() +errchk stropen, open, ic_fshow, ic_fvshowr, ic_fxyshowr, ic_ferrorsr + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Scan the command. + call sscan (cmd) + call gargwrd (Memc[str], SZ_LINE) + ncmd = strdic (Memc[str], Memc[str], SZ_LINE, CMDS) + call gargwrd (Memc[str], SZ_LINE) + + iferr { + # Setup the output. + deact = NO + msg = NULL + + if (nscan() == 1) { + if (GP_UIFNAME(IC_GP(ic)) != EOS) { + call malloc (msg, 100000, TY_CHAR) + fd = stropen (Memc[msg], 100000, WRITE_ONLY) + } else { + fd = open ("STDOUT", APPEND, TEXT_FILE) + call gdeactivate (IC_GP(ic), AW_CLEAR) + deact = YES + } + } else + fd = open (Memc[str], APPEND, TEXT_FILE) + + # Write the results to the output. + switch (ncmd) { + case SHOW: + call ic_fshow (ic, fd) + case VSHOW: + call ic_fvshowr (ic, cv, x, y, wts, npts, fd) + case XYSHOW: + call ic_fxyshowr (ic, cv, x, y, wts, npts, fd) + case ERRORS: + call ic_fshow (ic, fd) + call ic_ferrorsr (ic, cv, x, y, wts, npts, fd) + } + + # Flush the output. + call close (fd) + if (msg != NULL) + call gmsg (IC_GP(ic), "icshow", Memc[msg]) + } then + call erract (EA_WARN) + + if (msg != NULL) + call mfree (msg, TY_CHAR) + if (deact == YES) + call greactivate (IC_GP(ic), AW_PAUSE) + call sfree (sp) +end diff --git a/pkg/xtools/icfit/icgundelete.gx b/pkg/xtools/icfit/icgundelete.gx new file mode 100644 index 00000000..c997ccd0 --- /dev/null +++ b/pkg/xtools/icfit/icgundelete.gx @@ -0,0 +1,93 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <mach.h> +include <pkg/gtools.h> +include "icfit.h" + +define MSIZE 2. # Mark size + +# ICG_UNDELETE -- Undelete data point nearest the cursor. +# The nearest point to the cursor in NDC coordinates is determined. + +procedure icg_undelete$t (ic, gp, gt, cv, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +PIXEL x[npts], y[npts] # Data points +PIXEL wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +pointer sp, xout, yout + +int gt_geti() + +begin + call smark (sp) + call salloc (xout, npts, TY_PIXEL) + call salloc (yout, npts, TY_PIXEL) + + call icg_axes$t (ic, gt, cv, 1, x, y, Mem$t[xout], npts) + call icg_axes$t (ic, gt, cv, 2, x, y, Mem$t[yout], npts) + + if (gt_geti (gt, GTTRANSPOSE) == NO) + call icg_u1$t (ic, gp, Mem$t[xout], Mem$t[yout], wts, userwts, + npts, wx, wy) + else + call icg_u1$t (ic, gp, Mem$t[yout], Mem$t[xout], wts, userwts, + npts, wy, wx) + + call sfree (sp) +end + + +# ICG_U1 -- Do the actual undelete. + +procedure icg_u1$t (ic, gp, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +PIXEL x[npts], y[npts] # Data points +PIXEL wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with zero weight. + + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] != 0.) + next + + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Unmark the deleted point and reset the weight. + + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gseti (gp, G_PMLTYPE, GL_CLEAR) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + call gseti (gp, G_PMLTYPE, GL_SOLID) + call gline (gp, real (x[j]), real (y[j]), real (x[j]), real (y[j])) + wts[j] = userwts[j] + IC_NEWWTS(ic) = YES + } +end diff --git a/pkg/xtools/icfit/icgundeleted.x b/pkg/xtools/icfit/icgundeleted.x new file mode 100644 index 00000000..df295a92 --- /dev/null +++ b/pkg/xtools/icfit/icgundeleted.x @@ -0,0 +1,93 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <mach.h> +include <pkg/gtools.h> +include "icfit.h" + +define MSIZE 2. # Mark size + +# ICG_UNDELETE -- Undelete data point nearest the cursor. +# The nearest point to the cursor in NDC coordinates is determined. + +procedure icg_undeleted (ic, gp, gt, cv, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +double x[npts], y[npts] # Data points +double wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +pointer sp, xout, yout + +int gt_geti() + +begin + call smark (sp) + call salloc (xout, npts, TY_DOUBLE) + call salloc (yout, npts, TY_DOUBLE) + + call icg_axesd (ic, gt, cv, 1, x, y, Memd[xout], npts) + call icg_axesd (ic, gt, cv, 2, x, y, Memd[yout], npts) + + if (gt_geti (gt, GTTRANSPOSE) == NO) + call icg_u1d (ic, gp, Memd[xout], Memd[yout], wts, userwts, + npts, wx, wy) + else + call icg_u1d (ic, gp, Memd[yout], Memd[xout], wts, userwts, + npts, wy, wx) + + call sfree (sp) +end + + +# ICG_U1 -- Do the actual undelete. + +procedure icg_u1d (ic, gp, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +double x[npts], y[npts] # Data points +double wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with zero weight. + + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] != 0.) + next + + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Unmark the deleted point and reset the weight. + + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gseti (gp, G_PMLTYPE, GL_CLEAR) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + call gseti (gp, G_PMLTYPE, GL_SOLID) + call gline (gp, real (x[j]), real (y[j]), real (x[j]), real (y[j])) + wts[j] = userwts[j] + IC_NEWWTS(ic) = YES + } +end diff --git a/pkg/xtools/icfit/icgundeleter.x b/pkg/xtools/icfit/icgundeleter.x new file mode 100644 index 00000000..a1db4dca --- /dev/null +++ b/pkg/xtools/icfit/icgundeleter.x @@ -0,0 +1,93 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <mach.h> +include <pkg/gtools.h> +include "icfit.h" + +define MSIZE 2. # Mark size + +# ICG_UNDELETE -- Undelete data point nearest the cursor. +# The nearest point to the cursor in NDC coordinates is determined. + +procedure icg_undeleter (ic, gp, gt, cv, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +real x[npts], y[npts] # Data points +real wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +pointer sp, xout, yout + +int gt_geti() + +begin + call smark (sp) + call salloc (xout, npts, TY_REAL) + call salloc (yout, npts, TY_REAL) + + call icg_axesr (ic, gt, cv, 1, x, y, Memr[xout], npts) + call icg_axesr (ic, gt, cv, 2, x, y, Memr[yout], npts) + + if (gt_geti (gt, GTTRANSPOSE) == NO) + call icg_u1r (ic, gp, Memr[xout], Memr[yout], wts, userwts, + npts, wx, wy) + else + call icg_u1r (ic, gp, Memr[yout], Memr[xout], wts, userwts, + npts, wy, wx) + + call sfree (sp) +end + + +# ICG_U1 -- Do the actual undelete. + +procedure icg_u1r (ic, gp, x, y, wts, userwts, npts, wx, wy) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +real x[npts], y[npts] # Data points +real wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with zero weight. + + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] != 0.) + next + + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Unmark the deleted point and reset the weight. + + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gseti (gp, G_PMLTYPE, GL_CLEAR) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + call gseti (gp, G_PMLTYPE, GL_SOLID) + call gline (gp, real (x[j]), real (y[j]), real (x[j]), real (y[j])) + wts[j] = userwts[j] + IC_NEWWTS(ic) = YES + } +end diff --git a/pkg/xtools/icfit/icguser.x b/pkg/xtools/icfit/icguser.x new file mode 100644 index 00000000..58727343 --- /dev/null +++ b/pkg/xtools/icfit/icguser.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ICG_USER -- User default action + +procedure icg_user (ic, gp, gt, cv, wx, wy, wcs, key, cmd) + +pointer ic # ICFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer cv # CURFIT pointer +real wx, wy # Cursor positions +int wcs # GIO WCS +int key # Cursor key +char cmd[ARB] # Cursor command + +begin + # Ring bell + call printf ("\07\n") +end diff --git a/pkg/xtools/icfit/iclist.gx b/pkg/xtools/icfit/iclist.gx new file mode 100644 index 00000000..73af2f4e --- /dev/null +++ b/pkg/xtools/icfit/iclist.gx @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "icfit.h" +include "names.h" + +# IC_LIST -- List X, Y, FIT, W. + +procedure ic_list$t (ic, cv, x, y, wts, npts, file) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +PIXEL x[ARB] # Ordinates +PIXEL y[ARB] # Abscissas +PIXEL wts[ARB] # Weights +int npts # Number of data points +char file[ARB] # Output file + +int i, fd, open() +PIXEL $tcveval() +errchk open() + +begin + # Open the output file. + fd = open (file, APPEND, TEXT_FILE) + + if (npts == IC_NFIT(ic)) { + do i = 1, npts { + call fprintf (fd, "%8g %8g %8g %8g\n") + call parg$t (x[i]) + call parg$t (y[i]) + call parg$t ($tcveval (cv, x[i])) + call parg$t (wts[i]) + } + } else { + do i = 1, IC_NFIT(ic) { + call fprintf (fd, "%8g %8g %8g %8g\n") + call parg$t (Mem$t[IC_XFIT(ic)+i-1]) + call parg$t (Mem$t[IC_YFIT(ic)+i-1]) + call parg$t ($tcveval (cv, Mem$t[IC_XFIT(ic)+i-1])) + call parg$t (Mem$t[IC_WTSFIT(ic)+i-1]) + } + } + + call close (fd) +end diff --git a/pkg/xtools/icfit/iclistd.x b/pkg/xtools/icfit/iclistd.x new file mode 100644 index 00000000..78eb6058 --- /dev/null +++ b/pkg/xtools/icfit/iclistd.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "icfit.h" +include "names.h" + +# IC_LIST -- List X, Y, FIT, W. + +procedure ic_listd (ic, cv, x, y, wts, npts, file) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +double x[ARB] # Ordinates +double y[ARB] # Abscissas +double wts[ARB] # Weights +int npts # Number of data points +char file[ARB] # Output file + +int i, fd, open() +double dcveval() +errchk open() + +begin + # Open the output file. + fd = open (file, APPEND, TEXT_FILE) + + if (npts == IC_NFIT(ic)) { + do i = 1, npts { + call fprintf (fd, "%8g %8g %8g %8g\n") + call pargd (x[i]) + call pargd (y[i]) + call pargd (dcveval (cv, x[i])) + call pargd (wts[i]) + } + } else { + do i = 1, IC_NFIT(ic) { + call fprintf (fd, "%8g %8g %8g %8g\n") + call pargd (Memd[IC_XFIT(ic)+i-1]) + call pargd (Memd[IC_YFIT(ic)+i-1]) + call pargd (dcveval (cv, Memd[IC_XFIT(ic)+i-1])) + call pargd (Memd[IC_WTSFIT(ic)+i-1]) + } + } + + call close (fd) +end diff --git a/pkg/xtools/icfit/iclistr.x b/pkg/xtools/icfit/iclistr.x new file mode 100644 index 00000000..4e2b2c14 --- /dev/null +++ b/pkg/xtools/icfit/iclistr.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "icfit.h" +include "names.h" + +# IC_LIST -- List X, Y, FIT, W. + +procedure ic_listr (ic, cv, x, y, wts, npts, file) + +pointer ic # ICFIT pointer +pointer cv # Curfit pointer +real x[ARB] # Ordinates +real y[ARB] # Abscissas +real wts[ARB] # Weights +int npts # Number of data points +char file[ARB] # Output file + +int i, fd, open() +real rcveval() +errchk open() + +begin + # Open the output file. + fd = open (file, APPEND, TEXT_FILE) + + if (npts == IC_NFIT(ic)) { + do i = 1, npts { + call fprintf (fd, "%8g %8g %8g %8g\n") + call pargr (x[i]) + call pargr (y[i]) + call pargr (rcveval (cv, x[i])) + call pargr (wts[i]) + } + } else { + do i = 1, IC_NFIT(ic) { + call fprintf (fd, "%8g %8g %8g %8g\n") + call pargr (Memr[IC_XFIT(ic)+i-1]) + call pargr (Memr[IC_YFIT(ic)+i-1]) + call pargr (rcveval (cv, Memr[IC_XFIT(ic)+i-1])) + call pargr (Memr[IC_WTSFIT(ic)+i-1]) + } + } + + call close (fd) +end diff --git a/pkg/xtools/icfit/icparams.x b/pkg/xtools/icfit/icparams.x new file mode 100644 index 00000000..da829ce0 --- /dev/null +++ b/pkg/xtools/icfit/icparams.x @@ -0,0 +1,388 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "icfit.h" + +define FUNCTIONS "|chebyshev|legendre|spline3|spline1|user|" + +# IC_OPEN -- Open ICFIT parameter structure. + +procedure ic_open (ic) + +pointer ic # ICFIT pointer + +begin + # Allocate memory for the package parameter structure. + call malloc (ic, IC_LENSTRUCT, TY_STRUCT) + call malloc (IC_SAMPLE(ic), IC_SZSAMPLE, TY_CHAR) + call malloc (IC_LABELS(ic,1), SZ_LINE, TY_CHAR) + call malloc (IC_LABELS(ic,2), SZ_LINE, TY_CHAR) + call malloc (IC_UNITS(ic,1), SZ_LINE, TY_CHAR) + call malloc (IC_UNITS(ic,2), SZ_LINE, TY_CHAR) + call malloc (IC_HELP(ic), SZ_FNAME, TY_CHAR) + + # Initialize parameters + IC_OVERPLOT(ic) = NO + IC_RG(ic) = NULL + IC_XFIT(ic) = NULL + IC_YFIT(ic) = NULL + IC_WTSFIT(ic) = NULL + IC_REJPTS(ic) = NULL + IC_GP(ic) = NULL + IC_GT(ic) = NULL + + # Set defaults + call ic_pstr (ic, "function", "spline3") + call ic_puti (ic, "order", 1) + call ic_pstr (ic, "sample", "*") + call ic_puti (ic, "naverage", 1) + call ic_puti (ic, "niterate", 0) + call ic_putr (ic, "low", 3.) + call ic_putr (ic, "high", 3.) + call ic_putr (ic, "grow", 0.) + call ic_puti (ic, "markrej", YES) + call ic_pstr (ic, "xlabel", "X") + call ic_pstr (ic, "ylabel", "Y") + call ic_pstr (ic, "xunits", "") + call ic_pstr (ic, "yunits", "") + call ic_puti (ic, "color", 1) + call ic_pstr (ic, "help", IC_DEFHELP) + call ic_puti (ic, "key", 1) + call ic_pkey (ic, 1, 'x', 'y') + call ic_pkey (ic, 2, 'y', 'x') + call ic_pkey (ic, 3, 'x', 'r') + call ic_pkey (ic, 4, 'x', 'd') + call ic_pkey (ic, 5, 'x', 'n') +end + + +# IC_COPY -- Copy an ICFIT structure. +# The output pointer must be allocated already. + +procedure ic_copy (icin, icout) + +pointer icin # Input ICFIT pointer to copy +pointer icout # Ouput ICFIT pointer + +begin + IC_FUNCTION(icout) = IC_FUNCTION(icin) + IC_ORDER(icout) = IC_ORDER(icin) + IC_NAVERAGE(icout) = IC_NAVERAGE(icin) + IC_NITERATE(icout) = IC_NITERATE(icin) + IC_XMIN(icout) = IC_XMIN(icin) + IC_XMAX(icout) = IC_XMAX(icin) + IC_LOW(icout) = IC_LOW(icin) + IC_HIGH(icout) = IC_HIGH(icin) + IC_GROW(icout) = IC_GROW(icin) + IC_COLOR(icout) = IC_COLOR(icin) + IC_MARKREJ(icout) = IC_MARKREJ(icin) + IC_GKEY(icout) = IC_GKEY(icin) + + call strcpy (Memc[IC_SAMPLE(icin)], Memc[IC_SAMPLE(icout)], IC_SZSAMPLE) + call strcpy (Memc[IC_LABELS(icin,1)], Memc[IC_LABELS(icout,1)], SZ_LINE) + call strcpy (Memc[IC_LABELS(icin,2)], Memc[IC_LABELS(icout,2)], SZ_LINE) + call strcpy (Memc[IC_UNITS(icin,1)], Memc[IC_UNITS(icout,1)], SZ_LINE) + call strcpy (Memc[IC_UNITS(icin,2)], Memc[IC_UNITS(icout,2)], SZ_LINE) + call strcpy (Memc[IC_HELP(icin)], Memc[IC_HELP(icout)], SZ_LINE) + + call amovi (IC_AXES(icin,1,1), IC_AXES(icout,1,1), 10) + + IC_RG(icout) = NULL + IC_XFIT(icout) = NULL + IC_YFIT(icout) = NULL + IC_WTSFIT(icout) = NULL + IC_REJPTS(icout) = NULL +end + + +# IC_CLOSER -- Close ICFIT parameter structure. + +procedure ic_closer (ic) + +pointer ic # ICFIT pointer + +begin + if (ic != NULL) { + # Free memory for the package parameter structure. + call rg_free (IC_RG(ic)) + call mfree (IC_XFIT(ic), TY_REAL) + call mfree (IC_YFIT(ic), TY_REAL) + call mfree (IC_WTSFIT(ic), TY_REAL) + call mfree (IC_REJPTS(ic), TY_INT) + call mfree (IC_SAMPLE(ic), TY_CHAR) + call mfree (IC_LABELS(ic,1), TY_CHAR) + call mfree (IC_LABELS(ic,2), TY_CHAR) + call mfree (IC_UNITS(ic,1), TY_CHAR) + call mfree (IC_UNITS(ic,2), TY_CHAR) + call mfree (IC_HELP(ic), TY_CHAR) + call mfree (ic, TY_STRUCT) + } +end + + +# IC_CLOSED -- Close ICFIT parameter structure. + +procedure ic_closed (ic) + +pointer ic # ICFIT pointer + +begin + if (ic != NULL) { + # Free memory for the package parameter structure. + call rg_free (IC_RG(ic)) + call mfree (IC_XFIT(ic), TY_DOUBLE) + call mfree (IC_YFIT(ic), TY_DOUBLE) + call mfree (IC_WTSFIT(ic), TY_DOUBLE) + call mfree (IC_REJPTS(ic), TY_INT) + call mfree (IC_SAMPLE(ic), TY_CHAR) + call mfree (IC_LABELS(ic,1), TY_CHAR) + call mfree (IC_LABELS(ic,2), TY_CHAR) + call mfree (IC_UNITS(ic,1), TY_CHAR) + call mfree (IC_UNITS(ic,2), TY_CHAR) + call mfree (IC_HELP(ic), TY_CHAR) + call mfree (ic, TY_STRUCT) + } +end + + +# IC_PSTR -- Put string valued parameters. + +procedure ic_pstr (ic, param, str) + +pointer ic # ICFIT pointer +char param[ARB] # Parameter to be put +char str[ARB] # String value + +int i +pointer ptr + +int strdic() +bool streq() + +begin + if (streq (param, "sample")) + call strcpy (str, Memc[IC_SAMPLE(ic)], IC_SZSAMPLE) + else if (streq (param, "function")) { + call malloc (ptr, SZ_LINE, TY_CHAR) + i = strdic (str, Memc[ptr], SZ_LINE, FUNCTIONS) + if (i > 0) + IC_FUNCTION(ic) = i + call mfree (ptr, TY_CHAR) + } else if (streq (param, "xlabel")) + call strcpy (str, Memc[IC_LABELS(ic,1)], SZ_LINE) + else if (streq (param, "ylabel")) + call strcpy (str, Memc[IC_LABELS(ic,2)], SZ_LINE) + else if (streq (param, "xunits")) + call strcpy (str, Memc[IC_UNITS(ic,1)], SZ_LINE) + else if (streq (param, "yunits")) + call strcpy (str, Memc[IC_UNITS(ic,2)], SZ_LINE) + else if (streq (param, "help")) + call strcpy (str, Memc[IC_HELP(ic)], SZ_LINE) + else + call error (0, "ICFIT: Unknown parameter") + + call ic_gui (ic, "params") +end + + +# IC_PUTI -- Put integer valued parameters. + +procedure ic_puti (ic, param, ival) + +pointer ic # ICFIT pointer +char param[ARB] # Parameter to be put +int ival # Integer value + +bool streq() + +begin + if (streq (param, "naverage")) + IC_NAVERAGE(ic) = ival + else if (streq (param, "order")) + IC_ORDER(ic) = max (1, ival) + else if (streq (param, "niterate")) + IC_NITERATE(ic) = ival + else if (streq (param, "key")) + IC_GKEY(ic) = ival + else if (streq (param, "color")) + IC_COLOR(ic) = ival + else if (streq (param, "markrej")) + IC_MARKREJ(ic) = ival + else + call error (0, "ICFIT: Unknown parameter") + + call ic_gui (ic, "params") +end + + +# IC_PKEY -- Put key parameters. +# Note the key types must be integers not characters. + +procedure ic_pkey (ic, key, xaxis, yaxis) + +pointer ic # ICFIT pointer +int key # Key to be defined +int xaxis # X axis type +int yaxis # Y axis type + +begin + if (key >= 1 && key <= 5) { + IC_AXES(ic, key, 1) = xaxis + IC_AXES(ic, key, 2) = yaxis + + if (key == IC_GKEY(ic)) + call ic_gui (ic, "graph") + } +end + + +# IC_GKEY -- Get key parameters. + +procedure ic_gkey (ic, key, xaxis, yaxis) + +pointer ic # ICFIT pointer +int key # Key to be gotten +int xaxis # X axis type +int yaxis # Y axis type + +begin + xaxis = IC_AXES(ic, key, 1) + yaxis = IC_AXES(ic, key, 2) +end + + +# IC_PUTR -- Put real valued parameters. + +procedure ic_putr (ic, param, rval) + +pointer ic # ICFIT pointer +char param[ARB] # Parameter to be put +real rval # Real value + +bool streq() + +begin + if (streq (param, "xmin")) + IC_XMIN(ic) = rval + else if (streq (param, "xmax")) + IC_XMAX(ic) = rval + else if (streq (param, "low")) + IC_LOW(ic) = rval + else if (streq (param, "high")) + IC_HIGH(ic) = rval + else if (streq (param, "grow")) + IC_GROW(ic) = rval + else + call error (0, "ICFIT: Unknown parameter") + + call ic_gui (ic, "params") +end + + +# IC_GSTR -- Get string valued parameters. + +procedure ic_gstr (ic, param, str, maxchars) + +pointer ic # ICFIT pointer +char param[ARB] # Parameter to be put +char str[maxchars] # String value +int maxchars # Maximum number of characters + +bool streq() + +begin + if (streq (param, "sample")) + call strcpy (Memc[IC_SAMPLE(ic)], str, maxchars) + else if (streq (param, "xlabel")) + call strcpy (Memc[IC_LABELS(ic,1)], str, maxchars) + else if (streq (param, "ylabel")) + call strcpy (Memc[IC_LABELS(ic,2)], str, maxchars) + else if (streq (param, "xunits")) + call strcpy (Memc[IC_UNITS(ic,1)], str, maxchars) + else if (streq (param, "yunits")) + call strcpy (Memc[IC_UNITS(ic,2)], str, maxchars) + else if (streq (param, "help")) + call strcpy (Memc[IC_HELP(ic)], str, maxchars) + else if (streq (param, "function")) { + switch (IC_FUNCTION(ic)) { + case 1: + call strcpy ("chebyshev", str, maxchars) + case 2: + call strcpy ("legendre", str, maxchars) + case 3: + call strcpy ("spline3", str, maxchars) + case 4: + call strcpy ("spline1", str, maxchars) + case 5: + call strcpy ("user", str, maxchars) + } + } else + call error (0, "ICFIT: Unknown parameter") +end + + +# IC_GETI -- Get integer valued parameters. + +int procedure ic_geti (ic, param) + +pointer ic # ICFIT pointer +char param[ARB] # Parameter to be gotten + +bool streq() + +begin + if (streq (param, "naverage")) + return (IC_NAVERAGE(ic)) + else if (streq (param, "order")) + return (IC_ORDER(ic)) + else if (streq (param, "niterate")) + return (IC_NITERATE(ic)) + else if (streq (param, "key")) + return (IC_GKEY(ic)) + else if (streq (param, "nfit")) + return (IC_NFIT(ic)) + else if (streq (param, "nreject")) + return (IC_NREJECT(ic)) + else if (streq (param, "rejpts")) + return (IC_REJPTS(ic)) + else if (streq (param, "color")) + return (IC_COLOR(ic)) + else if (streq (param, "markrej")) + return (IC_MARKREJ(ic)) + else if (streq (param, "nmin")) { + switch (IC_FUNCTION(ic)) { + case 3: + return (IC_ORDER(ic) + 3) + case 4: + return (IC_ORDER(ic) + 1) + default: + return (IC_ORDER(ic)) + } + } + + call error (0, "ICFIT: Unknown parameter") +end + + +# IC_GETR -- Get real valued parameters. + +real procedure ic_getr (ic, param) + +pointer ic # ICFIT pointer +char param[ARB] # Parameter to be put + +bool streq() + +begin + if (streq (param, "xmin")) + return (IC_XMIN(ic)) + else if (streq (param, "xmax")) + return (IC_XMAX(ic)) + else if (streq (param, "low")) + return (IC_LOW(ic)) + else if (streq (param, "high")) + return (IC_HIGH(ic)) + else if (streq (param, "grow")) + return (IC_GROW(ic)) + + call error (0, "ICFIT: Unknown parameter") +end diff --git a/pkg/xtools/icfit/icreject.gx b/pkg/xtools/icfit/icreject.gx new file mode 100644 index 00000000..79965384 --- /dev/null +++ b/pkg/xtools/icfit/icreject.gx @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "names.h" + +# IC_REJECT -- Reject points with large residuals from the fit. +# +# The sigma of the fit residuals is calculated. The rejection thresholds +# are set at low_reject*sigma and high_reject*sigma. Points outside the +# rejection threshold are rejected from the fit and flagged in the rejpts +# array. Finally, the remaining points are refit. + +procedure ic_reject$t (cv, x, y, w, rejpts, npts, low_reject, high_reject, + niterate, grow, nreject) + +pointer cv # Curve descriptor +PIXEL x[npts] # Input ordinates +PIXEL y[npts] # Input data values +PIXEL w[npts] # Weights +int rejpts[npts] # Points rejected +int npts # Number of input points +real low_reject, high_reject # Rejection threshold +int niterate # Number of rejection iterations +real grow # Rejection radius +int nreject # Number of points rejected + +int i, ierr, nit, newreject +errchk ic_deviant$t + +begin + # Initialize rejection. + nreject = 0 + call amovki (NO, rejpts, npts) + + if (niterate <= 0) + return + + # Find deviant points. If an error occurs reduce the number of + # iterations and start again. + iferr { + nit = 0 + do i = 1, niterate { + call ic_deviant$t (cv, x, y, w, rejpts, npts, low_reject, + high_reject, grow, YES, nreject, newreject) + nit = nit + 1 + if (newreject == 0) + break + } + } then { + call $tcvfit (cv, x, y, w, npts, WTS_USER, ierr) + nreject = 0 + call amovki (NO, rejpts, npts) + do i = 1, nit + call ic_deviant$t (cv, x, y, w, rejpts, npts, low_reject, + high_reject, grow, YES, nreject, newreject) + } +end diff --git a/pkg/xtools/icfit/icrejectd.x b/pkg/xtools/icfit/icrejectd.x new file mode 100644 index 00000000..36985923 --- /dev/null +++ b/pkg/xtools/icfit/icrejectd.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "names.h" + +# IC_REJECT -- Reject points with large residuals from the fit. +# +# The sigma of the fit residuals is calculated. The rejection thresholds +# are set at low_reject*sigma and high_reject*sigma. Points outside the +# rejection threshold are rejected from the fit and flagged in the rejpts +# array. Finally, the remaining points are refit. + +procedure ic_rejectd (cv, x, y, w, rejpts, npts, low_reject, high_reject, + niterate, grow, nreject) + +pointer cv # Curve descriptor +double x[npts] # Input ordinates +double y[npts] # Input data values +double w[npts] # Weights +int rejpts[npts] # Points rejected +int npts # Number of input points +real low_reject, high_reject # Rejection threshold +int niterate # Number of rejection iterations +real grow # Rejection radius +int nreject # Number of points rejected + +int i, ierr, nit, newreject +errchk ic_deviantd + +begin + # Initialize rejection. + nreject = 0 + call amovki (NO, rejpts, npts) + + if (niterate <= 0) + return + + # Find deviant points. If an error occurs reduce the number of + # iterations and start again. + iferr { + nit = 0 + do i = 1, niterate { + call ic_deviantd (cv, x, y, w, rejpts, npts, low_reject, + high_reject, grow, YES, nreject, newreject) + nit = nit + 1 + if (newreject == 0) + break + } + } then { + call dcvfit (cv, x, y, w, npts, WTS_USER, ierr) + nreject = 0 + call amovki (NO, rejpts, npts) + do i = 1, nit + call ic_deviantd (cv, x, y, w, rejpts, npts, low_reject, + high_reject, grow, YES, nreject, newreject) + } +end diff --git a/pkg/xtools/icfit/icrejectr.x b/pkg/xtools/icfit/icrejectr.x new file mode 100644 index 00000000..2e344279 --- /dev/null +++ b/pkg/xtools/icfit/icrejectr.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include "names.h" + +# IC_REJECT -- Reject points with large residuals from the fit. +# +# The sigma of the fit residuals is calculated. The rejection thresholds +# are set at low_reject*sigma and high_reject*sigma. Points outside the +# rejection threshold are rejected from the fit and flagged in the rejpts +# array. Finally, the remaining points are refit. + +procedure ic_rejectr (cv, x, y, w, rejpts, npts, low_reject, high_reject, + niterate, grow, nreject) + +pointer cv # Curve descriptor +real x[npts] # Input ordinates +real y[npts] # Input data values +real w[npts] # Weights +int rejpts[npts] # Points rejected +int npts # Number of input points +real low_reject, high_reject # Rejection threshold +int niterate # Number of rejection iterations +real grow # Rejection radius +int nreject # Number of points rejected + +int i, ierr, nit, newreject +errchk ic_deviantr + +begin + # Initialize rejection. + nreject = 0 + call amovki (NO, rejpts, npts) + + if (niterate <= 0) + return + + # Find deviant points. If an error occurs reduce the number of + # iterations and start again. + iferr { + nit = 0 + do i = 1, niterate { + call ic_deviantr (cv, x, y, w, rejpts, npts, low_reject, + high_reject, grow, YES, nreject, newreject) + nit = nit + 1 + if (newreject == 0) + break + } + } then { + call rcvfit (cv, x, y, w, npts, WTS_USER, ierr) + nreject = 0 + call amovki (NO, rejpts, npts) + do i = 1, nit + call ic_deviantr (cv, x, y, w, rejpts, npts, low_reject, + high_reject, grow, YES, nreject, newreject) + } +end diff --git a/pkg/xtools/icfit/icshow.x b/pkg/xtools/icfit/icshow.x new file mode 100644 index 00000000..d39e85d5 --- /dev/null +++ b/pkg/xtools/icfit/icshow.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "icfit.h" + +# IC_SHOW -- Show the values of the parameters. + +procedure ic_show (ic, file, gt) + +pointer ic # ICFIT pointer +char file[ARB] # Output file +pointer gt # GTOOLS pointer + +int fd, open() +errchk open, ic_fshow + +begin + fd = open (file, APPEND, TEXT_FILE) + IC_GT(ic) = gt + call ic_fshow (ic, fd) + call close (fd) +end diff --git a/pkg/xtools/icfit/icvshow.gx b/pkg/xtools/icfit/icvshow.gx new file mode 100644 index 00000000..f356cb14 --- /dev/null +++ b/pkg/xtools/icfit/icvshow.gx @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "icfit.h" + +# IC_VSHOW -- Show fit parameters in verbose mode. + +procedure ic_vshow$t (ic, file, cv, x, y, wts, npts, gt) + +pointer ic # ICFIT pointer +char file[ARB] # Output file +pointer cv # Curfit pointer +PIXEL x[ARB] # Ordinates +PIXEL y[ARB] # Abscissas +PIXEL wts[ARB] # Weights +int npts # Number of data points +pointer gt # Graphics tools pointer + +int fd, open() +errchk open, ic_fvshow$t + +begin + fd = open (file, APPEND, TEXT_FILE) + IC_GT(ic) = gt + call ic_fvshow$t (ic, cv, x, y, wts, npts, fd) + call close (fd) +end + + +# IC_XYSHOW -- List data as x, y, fit, weight lines on output. + +procedure ic_xyshow$t (ic, file, cv, x, y, w, npts) + +pointer ic # ICFIT pointer +char file[ARB] # Output file +pointer cv # Pointer to curfit structure +PIXEL x[npts] # Array of x data values +PIXEL y[npts] # Array of y data values +PIXEL w[npts] # Array of weight data values +int npts # Number of data values + +int fd, open() +errchk open, ic_fxyshow$t + +begin + fd = open (file, APPEND, TEXT_FILE) + call ic_fxyshow$t (ic, cv, x, y, w, npts, fd) + call close (fd) +end diff --git a/pkg/xtools/icfit/icvshowd.x b/pkg/xtools/icfit/icvshowd.x new file mode 100644 index 00000000..45b7ae85 --- /dev/null +++ b/pkg/xtools/icfit/icvshowd.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "icfit.h" + +# IC_VSHOW -- Show fit parameters in verbose mode. + +procedure ic_vshowd (ic, file, cv, x, y, wts, npts, gt) + +pointer ic # ICFIT pointer +char file[ARB] # Output file +pointer cv # Curfit pointer +double x[ARB] # Ordinates +double y[ARB] # Abscissas +double wts[ARB] # Weights +int npts # Number of data points +pointer gt # Graphics tools pointer + +int fd, open() +errchk open, ic_fvshowd + +begin + fd = open (file, APPEND, TEXT_FILE) + IC_GT(ic) = gt + call ic_fvshowd (ic, cv, x, y, wts, npts, fd) + call close (fd) +end + + +# IC_XYSHOW -- List data as x, y, fit, weight lines on output. + +procedure ic_xyshowd (ic, file, cv, x, y, w, npts) + +pointer ic # ICFIT pointer +char file[ARB] # Output file +pointer cv # Pointer to curfit structure +double x[npts] # Array of x data values +double y[npts] # Array of y data values +double w[npts] # Array of weight data values +int npts # Number of data values + +int fd, open() +errchk open, ic_fxyshowd + +begin + fd = open (file, APPEND, TEXT_FILE) + call ic_fxyshowd (ic, cv, x, y, w, npts, fd) + call close (fd) +end diff --git a/pkg/xtools/icfit/icvshowr.x b/pkg/xtools/icfit/icvshowr.x new file mode 100644 index 00000000..6f846ec8 --- /dev/null +++ b/pkg/xtools/icfit/icvshowr.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "icfit.h" + +# IC_VSHOW -- Show fit parameters in verbose mode. + +procedure ic_vshowr (ic, file, cv, x, y, wts, npts, gt) + +pointer ic # ICFIT pointer +char file[ARB] # Output file +pointer cv # Curfit pointer +real x[ARB] # Ordinates +real y[ARB] # Abscissas +real wts[ARB] # Weights +int npts # Number of data points +pointer gt # Graphics tools pointer + +int fd, open() +errchk open, ic_fvshowr + +begin + fd = open (file, APPEND, TEXT_FILE) + IC_GT(ic) = gt + call ic_fvshowr (ic, cv, x, y, wts, npts, fd) + call close (fd) +end + + +# IC_XYSHOW -- List data as x, y, fit, weight lines on output. + +procedure ic_xyshowr (ic, file, cv, x, y, w, npts) + +pointer ic # ICFIT pointer +char file[ARB] # Output file +pointer cv # Pointer to curfit structure +real x[npts] # Array of x data values +real y[npts] # Array of y data values +real w[npts] # Array of weight data values +int npts # Number of data values + +int fd, open() +errchk open, ic_fxyshowr + +begin + fd = open (file, APPEND, TEXT_FILE) + call ic_fxyshowr (ic, cv, x, y, w, npts, fd) + call close (fd) +end diff --git a/pkg/xtools/icfit/mkpkg b/pkg/xtools/icfit/mkpkg new file mode 100644 index 00000000..9ad67b9e --- /dev/null +++ b/pkg/xtools/icfit/mkpkg @@ -0,0 +1,85 @@ +# ICFIT package. + +$checkout libxtools.a lib$ +$update libxtools.a +$checkin libxtools.a lib$ +$exit + +generic: + $set GEN = "$$generic -k -t rd" + $ifolder (iccleanr.x, icclean.gx) $(GEN) icclean.gx $endif + $ifolder (icdeviantr.x, icdeviant.gx) $(GEN) icdeviant.gx $endif + $ifolder (icerrorsr.x, icerrors.gx) $(GEN) icerrors.gx $endif + $ifolder (icferrorsr.x, icferrors.gx) $(GEN) icferrors.gx $endif + $ifolder (icfitr.x, icfit.gx) $(GEN) icfit.gx $endif + $ifolder (icgaddr.x, icgadd.gx) $(GEN) icgadd.gx $endif + $ifolder (icgcolonr.x, icgcolon.gx) $(GEN) icgcolon.gx $endif + $ifolder (icgdeleter.x, icgdelete.gx) $(GEN) icgdelete.gx $endif + $ifolder (icgfitr.x, icgfit.gx) $(GEN) icgfit.gx $endif + $ifolder (icgaxesr.x, icgaxes.gx) $(GEN) icgaxes.gx $endif + $ifolder (icggraphr.x, icggraph.gx) $(GEN) icggraph.gx $endif + $ifolder (icgnearestr.x, icgnearest.gx) $(GEN) icgnearest.gx $endif + $ifolder (icgparamsr.x, icgparams.gx) $(GEN) icgparams.gx $endif + $ifolder (icgsampler.x, icgsample.gx) $(GEN) icgsample.gx $endif + $ifolder (icgundeleter.x, icgundelete.gx) $(GEN) icgundelete.gx $endif + $ifolder (icguaxesr.x, icguaxes.gx) $(GEN) icguaxes.gx $endif + $ifolder (icguishowr.x, icguishow.gx) $(GEN) icguishow.gx $endif + $ifolder (icrejectr.x, icreject.gx) $(GEN) icreject.gx $endif + $ifolder (icdosetupr.x, icdosetup.gx) $(GEN) icdosetup.gx $endif + $ifolder (icvshowr.x, icvshow.gx) $(GEN) icvshow.gx $endif + $ifolder (icfvshowr.x, icfvshow.gx) $(GEN) icfvshow.gx $endif + ; + +libxtools.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + iccleand.x icfit.h names.h <pkg/rg.h> + iccleanr.x icfit.h names.h <pkg/rg.h> + icdeviantd.x names.h <mach.h> <math/curfit.h> + icdeviantr.x names.h <mach.h> <math/curfit.h> + icdosetupd.x icfit.h names.h <math/curfit.h> + icdosetupr.x icfit.h names.h <math/curfit.h> + icerrorsd.x names.h + icerrorsr.x names.h + icferrorsd.x icfit.h names.h <math/curfit.h> + icferrorsr.x icfit.h names.h <math/curfit.h> + icfitd.x icfit.h names.h <error.h> <math/curfit.h> + icfitr.x icfit.h names.h <error.h> <math/curfit.h> + icfshow.x icfit.h <pkg/gtools.h> + icfvshowd.x icfit.h names.h <math/curfit.h> + icfvshowr.x icfit.h names.h <math/curfit.h> + icgaddd.x <gset.h> + icgaddr.x <gset.h> + icgaxesd.x icfit.h names.h <pkg/gtools.h> + icgaxesr.x icfit.h names.h <pkg/gtools.h> + icgcolond.x icfit.h names.h <error.h> <pkg/gtools.h> + icgcolonr.x icfit.h names.h <error.h> <pkg/gtools.h> + icgdeleted.x icfit.h <gset.h> <mach.h> <pkg/gtools.h> + icgdeleter.x icfit.h <gset.h> <mach.h> <pkg/gtools.h> + icgfitd.x icfit.h names.h <error.h> <pkg/gtools.h> + icgfitr.x icfit.h names.h <error.h> <pkg/gtools.h> + icggraphd.x icfit.h names.h <gset.h> <pkg/gtools.h> + icggraphr.x icfit.h names.h <gset.h> <pkg/gtools.h> + icgnearestd.x icfit.h <mach.h> <pkg/gtools.h> + icgnearestr.x icfit.h <mach.h> <pkg/gtools.h> + icgparamsd.x icfit.h names.h <pkg/gtools.h> + icgparamsr.x icfit.h names.h <pkg/gtools.h> + icgsampled.x icfit.h <gset.h> <mach.h> <pkg/gtools.h> <pkg/rg.h> + icgsampler.x icfit.h <gset.h> <mach.h> <pkg/gtools.h> <pkg/rg.h> + icguaxesd.x + icguaxesr.x + icgui.x icfit.h <gio.h> <gset.h> + icguishowd.x icfit.h names.h <error.h> <gio.h> <gset.h> + icguishowr.x icfit.h names.h <error.h> <gio.h> <gset.h> + icgundeleted.x icfit.h <gset.h> <mach.h> <pkg/gtools.h> + icgundeleter.x icfit.h <gset.h> <mach.h> <pkg/gtools.h> + icguser.x + iclistd.x icfit.h names.h + iclistr.x icfit.h names.h + icparams.x icfit.h + icrejectd.x names.h <math/curfit.h> + icrejectr.x names.h <math/curfit.h> + icshow.x icfit.h + icvshowd.x icfit.h + icvshowr.x icfit.h + ; diff --git a/pkg/xtools/icfit/names.h b/pkg/xtools/icfit/names.h new file mode 100644 index 00000000..6fce9473 --- /dev/null +++ b/pkg/xtools/icfit/names.h @@ -0,0 +1,21 @@ +# NAMES -- Map generic names to external names. + +define ic_cleanr ic_clean +define ic_fitr ic_fit +define icg_fitr icg_fit +define ic_freer ic_free +define ic_errorsr ic_errors + +define rcvcoeff cvcoeff +define rcverrors cverrors +define rcveval cveval +define rcvfit cvfit +define rcvfree cvfree +define rcvinit cvinit +define rcvrefit cvrefit +define rcvrject cvrject +define rcvsolve cvsolve +define rcvstati cvstati +define rcvvector cvvector +define rcvsave cvsave +define rcvuserfnc cvuserfnc diff --git a/pkg/xtools/imtools.x b/pkg/xtools/imtools.x new file mode 100644 index 00000000..e4ca8bd3 --- /dev/null +++ b/pkg/xtools/imtools.x @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <imhdr.h> + +# NEW_TITLE -- Get a new image title. +# The null string defaults to the original title. + +procedure new_title (param, im) + +char param[ARB] # Parameter +pointer im # Image descriptor +char title[SZ_LINE] +int strlen() + +begin + call clgstr (param, title, SZ_LINE) + if (strlen (title) > 0) + call strcpy (title, IM_TITLE(im), SZ_IMTITLE) +end + + +# NEW_PIXTYPE -- Get a new pixel datatype. +# The null string defaults to the original pixel datatype. + +procedure new_pixtype (param, im) + +char param[ARB] # Parameter +pointer im # Image descriptor + +char pixtype[7] +int type_codes[6], i +data type_codes /TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE, TY_COMPLEX/ +int strdic() + +begin + call clgstr ("pixtype", pixtype, 7) + i = strdic (pixtype, pixtype, 7, "|short|int|long|real|double|complex|") + if (i > 0) + IM_PIXTYPE(im) = type_codes[i] +end + + +# GET_ROOT -- Get the root name from an image. + +procedure get_root (image, root, maxch) + +char image[ARB] # Image name with possible section +char root[ARB] # Root image name +int maxch # Maximum length of root image name + +begin + call imgimage (image, root, maxch) +end + + +# GET_SECTION -- Get the image section from an image. + +procedure get_section (image, section, maxch) + +char image[ARB] # Image name with possible section +char section[ARB] # Section +int maxch # Maximum length of section + +begin + call imgsection (image, section, maxch) +end + + +# XT_MKIMTEMP -- Return the temporary output image name to be used. +# XT_DELIMTEMP -- Delete the temporary image. +# +# In order to have an output image be the same as the input +# image a temporary image is used. When the temporary image has been +# created it replaces the desired output image name. Only root names +# are considered. + +procedure xt_mkimtemp (input, output, original, sz_fname) + +char input[ARB] #I Input image +char output[ARB] #U Output image to use +char original[ARB] #O Root of original output image +int sz_fname #I Maximum size of image names + +pointer sp, inname, outname, extn +int i, j, k, gstrmatch(), strncmp(), fnextn() +bool xt_imnameeq() + +begin + call smark (sp) + call salloc (inname, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + # Strip image sections leaving only the path and root image name + # (with group and image kernel parameters). To change to + # remove group and image kernel stuff use imgcluster instead of + # imgimage. + + call imgimage (input, Memc[inname], SZ_FNAME) + if (gstrmatch (input, Memc[inname], i, k) > 0) + call strcpy (input, Memc[inname], k) + + call imgimage (output, Memc[outname], SZ_FNAME) + if (gstrmatch (output, Memc[outname], j, k) > 0) + call strcpy (output, Memc[outname], k) + + call strcpy (Memc[outname], output, sz_fname) + call strcpy (Memc[outname], original, sz_fname) + + # Check if the input and output images are the same. + # First check if the path names are the same and then if + # the image names are the same. If they are return a temporary + # image name with the same extension as the output image. + + if (i == j && strncmp (Memc[inname], Memc[outname], i-1) == 0) { + if (xt_imnameeq (Memc[inname], Memc[outname])) { + call mktemp ("tmp", output, sz_fname) + if (fnextn (original, Memc[extn], SZ_FNAME) > 0) { + call strcat (".", output, sz_fname) + call strcat (Memc[extn], output, sz_fname) + } + } + } + + call sfree (sp) +end + + +procedure xt_delimtemp (output, original) + +char output[ARB] # Output image +char original[ARB] # Temporary output image name + +bool strne() +errchk imdelete + +begin + # If the output image is not the same as the original output image name + # replace the original output image with the new image. + + if (strne (output, original)) { + iferr (call imdelete (original)) + ; + call imrename (output, original) + } +end diff --git a/pkg/xtools/inlfit/README b/pkg/xtools/inlfit/README new file mode 100644 index 00000000..56d72836 --- /dev/null +++ b/pkg/xtools/inlfit/README @@ -0,0 +1,165 @@ + THE INLFIT PACKAGE + +This subdirectory contains the routines of the interactive non-linear +least squares fitting package INLFIT. This package is layered on the NLFIT +package in MATH. NLFIT uses the Levenberg-Marquardt method to solve for +the parameters of a user specified non-linear equation. The user must supply +two routines. The first routine evaluates the function in terms of its +parameters. The second routine evaluates the function and its derivatives +in terms of its parameters. The user must also supply initial guesses for +the parameters and parameter increments, the list of parameters to be +varied during the fitting process, a fitting tolerance, and the maximum +number of iterations. + +The entry points into the INLFIT package are listed below. + + ininit - Initialize the fitting routines + inget - Get the value of an INLFIT parameter + input - Store the value of an INLFIT parameter + ingkey - Get the value of an INLFIT graphics/axis parameter + inpkey - Store the value of an INLFIT graphics/axis parameter + infit - Fit the function non-interactively + ingfit - Fit the function interactively + inerrors - Compute the errors of the fit + infree - Free memory allocated by ininit + +The calling sequences for the above routines are listed below. The [iprd] +stand for integer, pointer, real and double precision versions of each +routine respectively. [str] stands for string. + + in_init[rd] (in, address(func), address(dfunc), param, dparam, + nparams, plist, nfparams) + [irdp]val = in_get[irdp] (in, param) + in_gstr (in, params, str, maxch) + in_put[irdp] (in, param, val) + in_pstr (in, param, str) + in_gkey (in, key, axis, type, varnum) + in_pkey (in, key, axis, type, varnum) + in_fit[rd] (in, nl, x, y, wts, npts, nvars, wtflag, stat) + ing_fit[rd] (in, gp, cursor, gt, nl, x, y, wts, names, npts, + nvars, len_names, wtflag, stat) + in_errors[rd] (in, nl, x, y, wts, npts, nvars, variance, + chisqr, scatter, rms, errors) + in_free[rd] (in) + + +The user supplied functions fnc and dfnc have the following calling +sequences. + + fnc (x, nvars, nparams, nparams, zfit) + dfnc (x, nvars, params, dparams, nparams, zfit, derivs) + +The addresses of the user supplied functions can be obtained with a call +to locpr as follows. + + address = locpr (fnc) + +The user definition for the INLFIT package can be found in the file +lib$pkg/inlfit.h and can be made available to user applications programs +with the statement "include <pkg/inlfit.h>". + +The permitted values for the param argument are the following. + +# Integer valued parameters (in_geti, in_puti) + +define INLFUNCTION # Fitting function +define INLDERIVATIVE # Fitting function derivatives +define INLNPARAMS # Total number of parameters +define INLNFPARAMS # Number of fitting parameters +define INLNVARS # Number of variables +define INLNPTS # Number of variables +define INLMAXITER # Max. number of iterations +define INLNREJECT # Number of rejection iterations +define INLNREJPTS # Number of rejected points +define INLUAXES # User plot function +define INLUCOLON # User colon function +define INLUFIT # User fit function +define INLOVERPLOT # Overplot next plot ? +define INLPLOTFIT # Overplot fit ? +define INLFITERROR # Error fit code +define INLGKEY # Graph key + + +# Real/double valued parameters (in_get[rd], in_put[rd]) + +define INLTOLERANCE # Tolerance of convergence +define INLLOW # Low rejection value +define INLHIGH # High rejection value +define INLGROW # Rejection growing radius + + +# Pointer valued parameters (in_getp, in_getp) + +define INLNL # NLFIT descriptor +define INLPARAM # Parameter vector +define INLDPARAM # Parameter change vector +define INLPLIST # Parameter list +define INLREJPTS # Rejected points +define INLXMIN # Minimum value for curve +define INLXMAX # Maximum value for curve +define INLSFLOAT # Floating point substructure +define INLSGAXES # Graphics substructure + + +# String valued parameters (in_gstr, in_pstr) + +define INLLABELS # standard axis labels +define INLUNITS # standard axis units +define INLFLABELS # Function labels +define INLFUNITS # Function units +define INLPLABELS # Parameter labels +define INLPUNITS # Parameter units +define INLVLABELS # Variable labels +define INLVUNITS # Variable units +define INLUSERLABELS # User plot labels +define INLUSERUNITS # User plot units +define INLHELP # Help file name +define INLPROMPT # Help prompt + + +The permitted values for the key argument are the following. + +# in_gkey, in_pkey + +define KEY_FUNCTION # Function +define KEY_FIT # Fit +define KEY_RESIDUALS # Residuals +define KEY_RATIO # Ratio +define KEY_NONLINEAR # Non-linear part +define KEY_VARIABLE # Variable (user or default) +define KEY_UAXIS # User plot function +define KEY_MIN # Min. key type +define KEY_MAX # Max. key type + +The permitted values for the axis argument are the following. + +# in_gkey, in_pkey + +define INLXAXIS # X axis +define INLYAXIS # Y axis + + +The permitted values of the weights flag argument wtflag input to +in_fit[rd] or in_gfit[rd], and the stat argument returned by in_fit[rd] +or in_gfit[rd] are defined in lib$math/nlfit.h. They can be included in +the user's application with the statement "include <math/nlfit.h>". +The values are listed below. + +# Permitted values for wtflag + +define WTS_USER # User supplied weights +define WTS_UNIFORM # Uniform weighting +define WTS_CHISQ # Chi-squared weighting +define WTS_SCATTER # Weights include computed scatter term + +# Permitted values for stat + +define DONE # Solution converged +define SINGULAR # Singular solution +define NO_DEG_FREEDOM # Too few points +define NOT_DONE # Solution did not converge. + +Note the pointer to the NLFIT structure nl is returned by the in_fit[rd] +and in_gfit[rd] routines and input to the in_errors[rd] routine. This +pointer must be freed separately with a call to nl_free when the fitting +process terminates. diff --git a/pkg/xtools/inlfit/incopy.gx b/pkg/xtools/inlfit/incopy.gx new file mode 100644 index 00000000..8165cf6d --- /dev/null +++ b/pkg/xtools/inlfit/incopy.gx @@ -0,0 +1,126 @@ +include <pkg/inlfit.h> +include "inlfitdef.h" + +# IN_COPY -- Copy INLFIT parameter structure, into another. The destination +# structure is allocated if the pointer is NULL. + +procedure in_copy$t (insrc, indst) + +pointer insrc # source INLFIT pointer +pointer indst # destination INLFIT pointer + +int in_geti() +PIXEL in_get$t() +pointer in_getp() + +begin +# # Debug. +# call eprintf ( +# "in_copy: insrc=%d, indst=%d\n") +# call pargi (insrc) +# call pargi (indst) + + # Allocate destination. + if (indst == NULL) { + + # Allocate structure memory. + call malloc (indst, LEN_INLSTRUCT, TY_STRUCT) + + # Allocate memory for parameter values, changes, and list. + call malloc (IN_PARAM (indst), in_geti (insrc, INLNPARAMS), + TY_PIXEL) + call malloc (IN_DPARAM (indst), in_geti (insrc, INLNPARAMS), + TY_PIXEL) + call malloc (IN_PLIST (indst), in_geti (insrc, INLNPARAMS), + TY_INT) + + # Allocate space for strings. All strings are limited + # to SZ_LINE or SZ_FNAME. + call malloc (IN_LABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_UNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_FLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_FUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_PLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_PUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_VLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_VUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_USERLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_USERUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_HELP (indst), SZ_FNAME, TY_CHAR) + call malloc (IN_PROMPT (indst), SZ_FNAME, TY_CHAR) + + # Allocate space for floating point and graph substructures. + call malloc (IN_SFLOAT (indst), LEN_INLFLOAT, TY_PIXEL) + call malloc (IN_SGAXES (indst), INLNGKEYS * LEN_INLGRAPH, TY_INT) + } + + # Copy integer parameters. + call in_puti (indst, INLFUNCTION, in_geti (insrc, INLFUNCTION)) + call in_puti (indst, INLDERIVATIVE, in_geti (insrc, INLDERIVATIVE)) + call in_puti (indst, INLNPARAMS, in_geti (insrc, INLNPARAMS)) + call in_puti (indst, INLNFPARAMS, in_geti (insrc, INLNFPARAMS)) + + # Copy parameter values, changes, and list. + call amov$t (Mem$t[in_getp (insrc, INLPARAM)], + Mem$t[in_getp (indst, INLPARAM)], + in_geti (insrc, INLNPARAMS)) + call amov$t (Mem$t[in_getp (insrc, INLDPARAM)], + Mem$t[in_getp (indst, INLDPARAM)], + in_geti (insrc, INLNPARAMS)) + call amovi (Memi[in_getp (insrc, INLPLIST)], + Memi[in_getp (indst, INLPLIST)], + in_geti (insrc, INLNPARAMS)) + + # Copy defaults. + call in_put$t (indst, INLTOLERANCE, in_get$t (insrc, INLTOLERANCE)) + call in_puti (indst, INLMAXITER, in_geti (insrc, INLMAXITER)) + call in_puti (indst, INLNREJECT, in_geti (insrc, INLNREJECT)) + call in_put$t (indst, INLLOW, in_get$t (insrc, INLLOW)) + call in_put$t (indst, INLHIGH, in_get$t (insrc, INLHIGH)) + call in_put$t (indst, INLGROW, in_get$t (insrc, INLGROW)) + + # Copy character strings. + call in_pstr (indst, INLLABELS, Memc[IN_LABELS (insrc)]) + call in_pstr (indst, INLUNITS, Memc[IN_UNITS (insrc)]) + call in_pstr (indst, INLFLABELS, Memc[IN_FLABELS (insrc)]) + call in_pstr (indst, INLFUNITS, Memc[IN_FUNITS (insrc)]) + call in_pstr (indst, INLPLABELS, Memc[IN_PLABELS (insrc)]) + call in_pstr (indst, INLPUNITS, Memc[IN_PUNITS (insrc)]) + call in_pstr (indst, INLVLABELS, Memc[IN_VLABELS (insrc)]) + call in_pstr (indst, INLVUNITS, Memc[IN_VUNITS (insrc)]) + call in_pstr (indst, INLUSERLABELS, Memc[IN_USERLABELS (insrc)]) + call in_pstr (indst, INLUSERUNITS, Memc[IN_USERUNITS (insrc)]) + call in_pstr (indst, INLHELP, Memc[IN_HELP (insrc)]) + call in_pstr (indst, INLPROMPT, Memc[IN_PROMPT (insrc)]) + + # Copy user defined functions. + call in_puti (indst, INLUAXES, in_geti (insrc, INLUAXES)) + call in_puti (indst, INLUCOLON, in_geti (insrc, INLUCOLON)) + call in_puti (indst, INLUFIT, in_geti (insrc, INLUFIT)) + + # Copy graph key, and axes. + call in_puti (indst, INLGKEY, in_geti (insrc, INLGKEY)) + call amovi (IN_SGAXES (insrc), IN_SGAXES (indst), + INLNGKEYS * LEN_INLGRAPH) + + # Copy flags and counters. + call in_puti (indst, INLOVERPLOT, in_geti (insrc, INLOVERPLOT)) + call in_puti (indst, INLPLOTFIT, in_geti (insrc, INLPLOTFIT)) + call in_puti (indst, INLNREJPTS, in_geti (insrc, INLNREJPTS)) + + # Initialize number of points and variables. + call in_puti (indst, INLNVARS, 0) + call in_puti (indst, INLNPTS, 0) + + # Reallocate rejected point list and limit values. + call in_bfinit (indst, in_geti (insrc, INLNPTS), + in_geti (insrc, INLNVARS)) + + # Copy rejected point list and limit values. + call amovi (MEMP[in_getp (insrc, INLREJPTS)], + MEMP[in_getp (indst, INLREJPTS)], in_geti (indst, INLNPTS)) + call amov$t (Mem$t[in_getp (insrc, INLXMIN)], + Mem$t[in_getp (indst, INLXMIN)], in_geti (indst, INLNVARS)) + call amov$t (Mem$t[in_getp (insrc, INLXMAX)], + Mem$t[in_getp (indst, INLXMAX)], in_geti (indst, INLNVARS)) +end diff --git a/pkg/xtools/inlfit/incopyd.x b/pkg/xtools/inlfit/incopyd.x new file mode 100644 index 00000000..01ae6793 --- /dev/null +++ b/pkg/xtools/inlfit/incopyd.x @@ -0,0 +1,126 @@ +include <pkg/inlfit.h> +include "inlfitdef.h" + +# IN_COPY -- Copy INLFIT parameter structure, into another. The destination +# structure is allocated if the pointer is NULL. + +procedure in_copyd (insrc, indst) + +pointer insrc # source INLFIT pointer +pointer indst # destination INLFIT pointer + +int in_geti() +double in_getd() +pointer in_getp() + +begin +# # Debug. +# call eprintf ( +# "in_copy: insrc=%d, indst=%d\n") +# call pargi (insrc) +# call pargi (indst) + + # Allocate destination. + if (indst == NULL) { + + # Allocate structure memory. + call malloc (indst, LEN_INLSTRUCT, TY_STRUCT) + + # Allocate memory for parameter values, changes, and list. + call malloc (IN_PARAM (indst), in_geti (insrc, INLNPARAMS), + TY_DOUBLE) + call malloc (IN_DPARAM (indst), in_geti (insrc, INLNPARAMS), + TY_DOUBLE) + call malloc (IN_PLIST (indst), in_geti (insrc, INLNPARAMS), + TY_INT) + + # Allocate space for strings. All strings are limited + # to SZ_LINE or SZ_FNAME. + call malloc (IN_LABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_UNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_FLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_FUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_PLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_PUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_VLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_VUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_USERLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_USERUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_HELP (indst), SZ_FNAME, TY_CHAR) + call malloc (IN_PROMPT (indst), SZ_FNAME, TY_CHAR) + + # Allocate space for floating point and graph substructures. + call malloc (IN_SFLOAT (indst), LEN_INLFLOAT, TY_DOUBLE) + call malloc (IN_SGAXES (indst), INLNGKEYS * LEN_INLGRAPH, TY_INT) + } + + # Copy integer parameters. + call in_puti (indst, INLFUNCTION, in_geti (insrc, INLFUNCTION)) + call in_puti (indst, INLDERIVATIVE, in_geti (insrc, INLDERIVATIVE)) + call in_puti (indst, INLNPARAMS, in_geti (insrc, INLNPARAMS)) + call in_puti (indst, INLNFPARAMS, in_geti (insrc, INLNFPARAMS)) + + # Copy parameter values, changes, and list. + call amovd (Memd[in_getp (insrc, INLPARAM)], + Memd[in_getp (indst, INLPARAM)], + in_geti (insrc, INLNPARAMS)) + call amovd (Memd[in_getp (insrc, INLDPARAM)], + Memd[in_getp (indst, INLDPARAM)], + in_geti (insrc, INLNPARAMS)) + call amovi (Memi[in_getp (insrc, INLPLIST)], + Memi[in_getp (indst, INLPLIST)], + in_geti (insrc, INLNPARAMS)) + + # Copy defaults. + call in_putd (indst, INLTOLERANCE, in_getd (insrc, INLTOLERANCE)) + call in_puti (indst, INLMAXITER, in_geti (insrc, INLMAXITER)) + call in_puti (indst, INLNREJECT, in_geti (insrc, INLNREJECT)) + call in_putd (indst, INLLOW, in_getd (insrc, INLLOW)) + call in_putd (indst, INLHIGH, in_getd (insrc, INLHIGH)) + call in_putd (indst, INLGROW, in_getd (insrc, INLGROW)) + + # Copy character strings. + call in_pstr (indst, INLLABELS, Memc[IN_LABELS (insrc)]) + call in_pstr (indst, INLUNITS, Memc[IN_UNITS (insrc)]) + call in_pstr (indst, INLFLABELS, Memc[IN_FLABELS (insrc)]) + call in_pstr (indst, INLFUNITS, Memc[IN_FUNITS (insrc)]) + call in_pstr (indst, INLPLABELS, Memc[IN_PLABELS (insrc)]) + call in_pstr (indst, INLPUNITS, Memc[IN_PUNITS (insrc)]) + call in_pstr (indst, INLVLABELS, Memc[IN_VLABELS (insrc)]) + call in_pstr (indst, INLVUNITS, Memc[IN_VUNITS (insrc)]) + call in_pstr (indst, INLUSERLABELS, Memc[IN_USERLABELS (insrc)]) + call in_pstr (indst, INLUSERUNITS, Memc[IN_USERUNITS (insrc)]) + call in_pstr (indst, INLHELP, Memc[IN_HELP (insrc)]) + call in_pstr (indst, INLPROMPT, Memc[IN_PROMPT (insrc)]) + + # Copy user defined functions. + call in_puti (indst, INLUAXES, in_geti (insrc, INLUAXES)) + call in_puti (indst, INLUCOLON, in_geti (insrc, INLUCOLON)) + call in_puti (indst, INLUFIT, in_geti (insrc, INLUFIT)) + + # Copy graph key, and axes. + call in_puti (indst, INLGKEY, in_geti (insrc, INLGKEY)) + call amovi (IN_SGAXES (insrc), IN_SGAXES (indst), + INLNGKEYS * LEN_INLGRAPH) + + # Copy flags and counters. + call in_puti (indst, INLOVERPLOT, in_geti (insrc, INLOVERPLOT)) + call in_puti (indst, INLPLOTFIT, in_geti (insrc, INLPLOTFIT)) + call in_puti (indst, INLNREJPTS, in_geti (insrc, INLNREJPTS)) + + # Initialize number of points and variables. + call in_puti (indst, INLNVARS, 0) + call in_puti (indst, INLNPTS, 0) + + # Reallocate rejected point list and limit values. + call in_bfinit (indst, in_geti (insrc, INLNPTS), + in_geti (insrc, INLNVARS)) + + # Copy rejected point list and limit values. + call amovi (MEMP[in_getp (insrc, INLREJPTS)], + MEMP[in_getp (indst, INLREJPTS)], in_geti (indst, INLNPTS)) + call amovd (Memd[in_getp (insrc, INLXMIN)], + Memd[in_getp (indst, INLXMIN)], in_geti (indst, INLNVARS)) + call amovd (Memd[in_getp (insrc, INLXMAX)], + Memd[in_getp (indst, INLXMAX)], in_geti (indst, INLNVARS)) +end diff --git a/pkg/xtools/inlfit/incopyr.x b/pkg/xtools/inlfit/incopyr.x new file mode 100644 index 00000000..1e698374 --- /dev/null +++ b/pkg/xtools/inlfit/incopyr.x @@ -0,0 +1,126 @@ +include <pkg/inlfit.h> +include "inlfitdef.h" + +# IN_COPY -- Copy INLFIT parameter structure, into another. The destination +# structure is allocated if the pointer is NULL. + +procedure in_copyr (insrc, indst) + +pointer insrc # source INLFIT pointer +pointer indst # destination INLFIT pointer + +int in_geti() +real in_getr() +pointer in_getp() + +begin +# # Debug. +# call eprintf ( +# "in_copy: insrc=%d, indst=%d\n") +# call pargi (insrc) +# call pargi (indst) + + # Allocate destination. + if (indst == NULL) { + + # Allocate structure memory. + call malloc (indst, LEN_INLSTRUCT, TY_STRUCT) + + # Allocate memory for parameter values, changes, and list. + call malloc (IN_PARAM (indst), in_geti (insrc, INLNPARAMS), + TY_REAL) + call malloc (IN_DPARAM (indst), in_geti (insrc, INLNPARAMS), + TY_REAL) + call malloc (IN_PLIST (indst), in_geti (insrc, INLNPARAMS), + TY_INT) + + # Allocate space for strings. All strings are limited + # to SZ_LINE or SZ_FNAME. + call malloc (IN_LABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_UNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_FLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_FUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_PLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_PUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_VLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_VUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_USERLABELS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_USERUNITS (indst), SZ_LINE, TY_CHAR) + call malloc (IN_HELP (indst), SZ_FNAME, TY_CHAR) + call malloc (IN_PROMPT (indst), SZ_FNAME, TY_CHAR) + + # Allocate space for floating point and graph substructures. + call malloc (IN_SFLOAT (indst), LEN_INLFLOAT, TY_REAL) + call malloc (IN_SGAXES (indst), INLNGKEYS * LEN_INLGRAPH, TY_INT) + } + + # Copy integer parameters. + call in_puti (indst, INLFUNCTION, in_geti (insrc, INLFUNCTION)) + call in_puti (indst, INLDERIVATIVE, in_geti (insrc, INLDERIVATIVE)) + call in_puti (indst, INLNPARAMS, in_geti (insrc, INLNPARAMS)) + call in_puti (indst, INLNFPARAMS, in_geti (insrc, INLNFPARAMS)) + + # Copy parameter values, changes, and list. + call amovr (Memr[in_getp (insrc, INLPARAM)], + Memr[in_getp (indst, INLPARAM)], + in_geti (insrc, INLNPARAMS)) + call amovr (Memr[in_getp (insrc, INLDPARAM)], + Memr[in_getp (indst, INLDPARAM)], + in_geti (insrc, INLNPARAMS)) + call amovi (Memi[in_getp (insrc, INLPLIST)], + Memi[in_getp (indst, INLPLIST)], + in_geti (insrc, INLNPARAMS)) + + # Copy defaults. + call in_putr (indst, INLTOLERANCE, in_getr (insrc, INLTOLERANCE)) + call in_puti (indst, INLMAXITER, in_geti (insrc, INLMAXITER)) + call in_puti (indst, INLNREJECT, in_geti (insrc, INLNREJECT)) + call in_putr (indst, INLLOW, in_getr (insrc, INLLOW)) + call in_putr (indst, INLHIGH, in_getr (insrc, INLHIGH)) + call in_putr (indst, INLGROW, in_getr (insrc, INLGROW)) + + # Copy character strings. + call in_pstr (indst, INLLABELS, Memc[IN_LABELS (insrc)]) + call in_pstr (indst, INLUNITS, Memc[IN_UNITS (insrc)]) + call in_pstr (indst, INLFLABELS, Memc[IN_FLABELS (insrc)]) + call in_pstr (indst, INLFUNITS, Memc[IN_FUNITS (insrc)]) + call in_pstr (indst, INLPLABELS, Memc[IN_PLABELS (insrc)]) + call in_pstr (indst, INLPUNITS, Memc[IN_PUNITS (insrc)]) + call in_pstr (indst, INLVLABELS, Memc[IN_VLABELS (insrc)]) + call in_pstr (indst, INLVUNITS, Memc[IN_VUNITS (insrc)]) + call in_pstr (indst, INLUSERLABELS, Memc[IN_USERLABELS (insrc)]) + call in_pstr (indst, INLUSERUNITS, Memc[IN_USERUNITS (insrc)]) + call in_pstr (indst, INLHELP, Memc[IN_HELP (insrc)]) + call in_pstr (indst, INLPROMPT, Memc[IN_PROMPT (insrc)]) + + # Copy user defined functions. + call in_puti (indst, INLUAXES, in_geti (insrc, INLUAXES)) + call in_puti (indst, INLUCOLON, in_geti (insrc, INLUCOLON)) + call in_puti (indst, INLUFIT, in_geti (insrc, INLUFIT)) + + # Copy graph key, and axes. + call in_puti (indst, INLGKEY, in_geti (insrc, INLGKEY)) + call amovi (IN_SGAXES (insrc), IN_SGAXES (indst), + INLNGKEYS * LEN_INLGRAPH) + + # Copy flags and counters. + call in_puti (indst, INLOVERPLOT, in_geti (insrc, INLOVERPLOT)) + call in_puti (indst, INLPLOTFIT, in_geti (insrc, INLPLOTFIT)) + call in_puti (indst, INLNREJPTS, in_geti (insrc, INLNREJPTS)) + + # Initialize number of points and variables. + call in_puti (indst, INLNVARS, 0) + call in_puti (indst, INLNPTS, 0) + + # Reallocate rejected point list and limit values. + call in_bfinit (indst, in_geti (insrc, INLNPTS), + in_geti (insrc, INLNVARS)) + + # Copy rejected point list and limit values. + call amovi (MEMP[in_getp (insrc, INLREJPTS)], + MEMP[in_getp (indst, INLREJPTS)], in_geti (indst, INLNPTS)) + call amovr (Memr[in_getp (insrc, INLXMIN)], + Memr[in_getp (indst, INLXMIN)], in_geti (indst, INLNVARS)) + call amovr (Memr[in_getp (insrc, INLXMAX)], + Memr[in_getp (indst, INLXMAX)], in_geti (indst, INLNVARS)) +end diff --git a/pkg/xtools/inlfit/indeviant.gx b/pkg/xtools/inlfit/indeviant.gx new file mode 100644 index 00000000..4ee2f372 --- /dev/null +++ b/pkg/xtools/inlfit/indeviant.gx @@ -0,0 +1,121 @@ +include <mach.h> + + +# IN_DEVIANT -- Find deviant points with large residuals from the fit +# and reject them from the fit. The sigma of the fit residuals is calculated. +# The rejection thresholds are set at (+/-)reject*sigma. Points outside the +# rejection threshold are recorded in the reject array. + +procedure in_deviant$t (nl, x, y, w, rejpts, npts, nvars, low_reject, + high_reject, grow, nreject, newreject) + +pointer nl # NLFIT descriptor +PIXEL x[ARB] # Input ordinates (npts * nvars) +PIXEL y[npts] # Input data values +PIXEL w[npts] # Weights +int rejpts[npts] # Points rejected +int npts # Number of input points +int nvars # Number of input variables +PIXEL low_reject, high_reject # Rejection thresholds +PIXEL grow # Rejection radius +int nreject # Number of points rejected (output) +int newreject # Number of new points rej. (output) + +int i, j, i_min, i_max, ilast +PIXEL sigma, low_cut, high_cut, residual +pointer sp, residuals + +begin +# # Debug. +# call eprintf ( +# "in_deviant: nl=%d, npts=%d, nvars=%d, low=%g, high=%g, grow=%g\n") +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) +# call parg$t (low_reject) +# call parg$t (high_reject) +# call parg$t (grow) + + # Initialize. + nreject = 0 + newreject = 0 + + # If low_reject and high_reject are zero then just return. + if ((low_reject == PIXEL (0.0)) && (high_reject == PIXEL (0.0))) + return + + # Allocate memory for the residuals. + call smark (sp) + call salloc (residuals, npts, TY_PIXEL) + + # Compute the residuals. + call nlvector$t (nl, x, Mem$t[residuals], npts, nvars) + call asub$t (y, Mem$t[residuals], Mem$t[residuals], npts) + + # Compute the sigma of the residuals. + j = 0 + sigma = PIXEL (0.0) + do i = 1, npts { + if ((w[i] != PIXEL (0.0)) && (rejpts[i] == NO)) { + sigma = sigma + Mem$t[residuals+i-1] ** 2 + j = j + 1 + } else if (rejpts[i] == YES) + nreject = nreject + 1 + } + + # If there are less than five points for the sigma calculation, + # just return. + + if (j < 5) { + call sfree (sp) + return + } else + sigma = sqrt (sigma / j) + + # Set the lower and upper cut limits according the the sigma value. + + if (low_reject > PIXEL (0.0)) + low_cut = -low_reject * sigma + else + low_cut = -MAX_REAL + if (high_reject > PIXEL (0.0)) + high_cut = high_reject * sigma + else + high_cut = MAX_REAL + + # Reject the residuals exceeding the rejection limits. + # A for loop is used instead of do because with region + # growing we want to modify the loop index. + + for (i = 1; i <= npts; i = i + 1) { + + # Do not process points with zero weigth or already rejected. + if ((w[i] == PIXEL (0.0)) || (rejpts[i] == YES)) + next + + # Reject point, and all other points closer than the growing + # factor. + + residual = Mem$t[residuals + i - 1] + if ((residual > high_cut) || (residual < low_cut)) { + + # Determine region to reject. + i_min = max (1, int (i - grow)) + i_max = min (npts, int (i + grow)) + + # Reject points from the fit and flag them. + do j = i_min, i_max { + if ((abs (x[i] - x[j]) <= grow) && (w[j] != PIXEL (0.0)) && + (rejpts[j] == NO)) { + rejpts[j] = YES + newreject = newreject + 1 + ilast = j + } + } + i = ilast + } + } + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/indeviantd.x b/pkg/xtools/inlfit/indeviantd.x new file mode 100644 index 00000000..ec32e637 --- /dev/null +++ b/pkg/xtools/inlfit/indeviantd.x @@ -0,0 +1,121 @@ +include <mach.h> + + +# IN_DEVIANT -- Find deviant points with large residuals from the fit +# and reject them from the fit. The sigma of the fit residuals is calculated. +# The rejection thresholds are set at (+/-)reject*sigma. Points outside the +# rejection threshold are recorded in the reject array. + +procedure in_deviantd (nl, x, y, w, rejpts, npts, nvars, low_reject, + high_reject, grow, nreject, newreject) + +pointer nl # NLFIT descriptor +double x[ARB] # Input ordinates (npts * nvars) +double y[npts] # Input data values +double w[npts] # Weights +int rejpts[npts] # Points rejected +int npts # Number of input points +int nvars # Number of input variables +double low_reject, high_reject # Rejection thresholds +double grow # Rejection radius +int nreject # Number of points rejected (output) +int newreject # Number of new points rej. (output) + +int i, j, i_min, i_max, ilast +double sigma, low_cut, high_cut, residual +pointer sp, residuals + +begin +# # Debug. +# call eprintf ( +# "in_deviant: nl=%d, npts=%d, nvars=%d, low=%g, high=%g, grow=%g\n") +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) +# call parg$t (low_reject) +# call parg$t (high_reject) +# call parg$t (grow) + + # Initialize. + nreject = 0 + newreject = 0 + + # If low_reject and high_reject are zero then just return. + if ((low_reject == double (0.0)) && (high_reject == double (0.0))) + return + + # Allocate memory for the residuals. + call smark (sp) + call salloc (residuals, npts, TY_DOUBLE) + + # Compute the residuals. + call nlvectord (nl, x, Memd[residuals], npts, nvars) + call asubd (y, Memd[residuals], Memd[residuals], npts) + + # Compute the sigma of the residuals. + j = 0 + sigma = double (0.0) + do i = 1, npts { + if ((w[i] != double (0.0)) && (rejpts[i] == NO)) { + sigma = sigma + Memd[residuals+i-1] ** 2 + j = j + 1 + } else if (rejpts[i] == YES) + nreject = nreject + 1 + } + + # If there are less than five points for the sigma calculation, + # just return. + + if (j < 5) { + call sfree (sp) + return + } else + sigma = sqrt (sigma / j) + + # Set the lower and upper cut limits according the the sigma value. + + if (low_reject > double (0.0)) + low_cut = -low_reject * sigma + else + low_cut = -MAX_REAL + if (high_reject > double (0.0)) + high_cut = high_reject * sigma + else + high_cut = MAX_REAL + + # Reject the residuals exceeding the rejection limits. + # A for loop is used instead of do because with region + # growing we want to modify the loop index. + + for (i = 1; i <= npts; i = i + 1) { + + # Do not process points with zero weigth or already rejected. + if ((w[i] == double (0.0)) || (rejpts[i] == YES)) + next + + # Reject point, and all other points closer than the growing + # factor. + + residual = Memd[residuals + i - 1] + if ((residual > high_cut) || (residual < low_cut)) { + + # Determine region to reject. + i_min = max (1, int (i - grow)) + i_max = min (npts, int (i + grow)) + + # Reject points from the fit and flag them. + do j = i_min, i_max { + if ((abs (x[i] - x[j]) <= grow) && (w[j] != double (0.0)) && + (rejpts[j] == NO)) { + rejpts[j] = YES + newreject = newreject + 1 + ilast = j + } + } + i = ilast + } + } + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/indeviantr.x b/pkg/xtools/inlfit/indeviantr.x new file mode 100644 index 00000000..334d7ef8 --- /dev/null +++ b/pkg/xtools/inlfit/indeviantr.x @@ -0,0 +1,121 @@ +include <mach.h> + + +# IN_DEVIANT -- Find deviant points with large residuals from the fit +# and reject them from the fit. The sigma of the fit residuals is calculated. +# The rejection thresholds are set at (+/-)reject*sigma. Points outside the +# rejection threshold are recorded in the reject array. + +procedure in_deviantr (nl, x, y, w, rejpts, npts, nvars, low_reject, + high_reject, grow, nreject, newreject) + +pointer nl # NLFIT descriptor +real x[ARB] # Input ordinates (npts * nvars) +real y[npts] # Input data values +real w[npts] # Weights +int rejpts[npts] # Points rejected +int npts # Number of input points +int nvars # Number of input variables +real low_reject, high_reject # Rejection thresholds +real grow # Rejection radius +int nreject # Number of points rejected (output) +int newreject # Number of new points rej. (output) + +int i, j, i_min, i_max, ilast +real sigma, low_cut, high_cut, residual +pointer sp, residuals + +begin +# # Debug. +# call eprintf ( +# "in_deviant: nl=%d, npts=%d, nvars=%d, low=%g, high=%g, grow=%g\n") +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) +# call parg$t (low_reject) +# call parg$t (high_reject) +# call parg$t (grow) + + # Initialize. + nreject = 0 + newreject = 0 + + # If low_reject and high_reject are zero then just return. + if ((low_reject == real (0.0)) && (high_reject == real (0.0))) + return + + # Allocate memory for the residuals. + call smark (sp) + call salloc (residuals, npts, TY_REAL) + + # Compute the residuals. + call nlvectorr (nl, x, Memr[residuals], npts, nvars) + call asubr (y, Memr[residuals], Memr[residuals], npts) + + # Compute the sigma of the residuals. + j = 0 + sigma = real (0.0) + do i = 1, npts { + if ((w[i] != real (0.0)) && (rejpts[i] == NO)) { + sigma = sigma + Memr[residuals+i-1] ** 2 + j = j + 1 + } else if (rejpts[i] == YES) + nreject = nreject + 1 + } + + # If there are less than five points for the sigma calculation, + # just return. + + if (j < 5) { + call sfree (sp) + return + } else + sigma = sqrt (sigma / j) + + # Set the lower and upper cut limits according the the sigma value. + + if (low_reject > real (0.0)) + low_cut = -low_reject * sigma + else + low_cut = -MAX_REAL + if (high_reject > real (0.0)) + high_cut = high_reject * sigma + else + high_cut = MAX_REAL + + # Reject the residuals exceeding the rejection limits. + # A for loop is used instead of do because with region + # growing we want to modify the loop index. + + for (i = 1; i <= npts; i = i + 1) { + + # Do not process points with zero weigth or already rejected. + if ((w[i] == real (0.0)) || (rejpts[i] == YES)) + next + + # Reject point, and all other points closer than the growing + # factor. + + residual = Memr[residuals + i - 1] + if ((residual > high_cut) || (residual < low_cut)) { + + # Determine region to reject. + i_min = max (1, int (i - grow)) + i_max = min (npts, int (i + grow)) + + # Reject points from the fit and flag them. + do j = i_min, i_max { + if ((abs (x[i] - x[j]) <= grow) && (w[j] != real (0.0)) && + (rejpts[j] == NO)) { + rejpts[j] = YES + newreject = newreject + 1 + ilast = j + } + } + i = ilast + } + } + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/indump.gx b/pkg/xtools/inlfit/indump.gx new file mode 100644 index 00000000..ee624a4e --- /dev/null +++ b/pkg/xtools/inlfit/indump.gx @@ -0,0 +1,233 @@ +include <pkg/inlfit.h> +include "inlfitdef.h" + +# IN_DUMP -- INLFIT debugging routine. + +procedure in_dump$t (fd, in) + +int fd # file descriptor +pointer in # INLFIT descriptor + +int i, npars, nfpars, nvars + +begin + # Test INLFIT pointer. + if (in == NULL) { + call fprintf (fd, "\n****** in_dump: Null INLFIT pointer\n") + call flush (fd) + return + } + + # File and INLFIT descriptors. + call fprintf (fd, "\n****** in_dump: (fd=%d), (in=%d)\n") + call pargi (fd) + call pargi (in) + call flush (fd) + + # Function and derivative pointers. + call fprintf (fd, "Fitting function pointer = %d\n") + call pargi (IN_FUNC (in)) + call fprintf (fd, "Derivative function pointer = %d\n") + call pargi (IN_DFUNC (in)) + call flush (fd) + + # Number of parameters, fitting parameters, and variables. + npars = IN_NPARAMS (in) + nfpars = IN_NFPARAMS (in) + nvars = IN_NVARS (in) + call fprintf (fd, "Number of parameters = %d\n") + call pargi (npars) + call fprintf (fd, "Number of fitted parameters = %d\n") + call pargi (nfpars) + call fprintf (fd, "Number of variables = %d\n") + call pargi (nvars) + call fprintf (fd, "Number of points = %d\n") + call pargi (IN_NPTS (in)) + call flush (fd) + + # Parameter values. + call fprintf (fd, "Parameter values (%d):\n") + call pargi (npars) + if (IN_PARAM (in) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call parg$t (Mem$t [IN_PARAM (in) + i - 1]) + } + } else + call fprintf (fd, "Null parameter value pointer\n") + call flush (fd) + + # Parameter changes. + if (IN_PARAM (in) != NULL) { + call fprintf (fd, "Parameter changes (%d):\n") + call pargi (npars) + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call parg$t (Mem$t [IN_DPARAM (in) + i - 1]) + } + } else + call fprintf (fd, "Null parameter change pointer\n") + call flush (fd) + + # Parameter list. + if (IN_PARAM (in) != NULL) { + call fprintf (fd, "Parameter list (%d):\n") + call pargi (npars) + do i = 1, npars { + call fprintf (fd, "%d -> %d\n") + call pargi (i) + call pargi (Memi[IN_PLIST (in) + i - 1]) + } + } else + call fprintf (fd, "Null parameter list pointer\n") + call flush (fd) + + # Floating point parameters. + if (IN_SFLOAT (in) != NULL) { + call fprintf (fd, "Fit tolerance = %g\n") + call parg$t (IN_TOL$T (in)) + call fprintf (fd, "Low reject = %g\n") + call parg$t (IN_LOW$T (in)) + call fprintf (fd, "High reject = %g\n") + call parg$t (IN_HIGH$T (in)) + call fprintf (fd, "Growing radius = %g\n") + call parg$t (IN_GROW$T (in)) + } else + call fprintf (fd, "Null floating point pointer\n") + call flush (fd) + + # Max number of iterations, and rejection iterations. + call fprintf (fd, "Maximum number of iterations = %d\n") + call pargi (IN_MAXITER (in)) + call fprintf (fd, "Number of rejection iterations = %d\n") + call pargi (IN_MAXITER (in)) + + # Rejected points. + call fprintf (fd, "Number of rejected points = %d\n") + call pargi (IN_NREJPTS (in)) + call fprintf (fd, "Rejected point list pointer = %d\n") + call pargi (IN_REJPTS (in)) + + # User procedures. + call fprintf (fd, "User axis procedure pointer = %d\n") + call pargi (IN_UAXES (in)) + call fprintf (fd, "User colon procedure pointer = %d\n") + call pargi (IN_UCOLON (in)) + call fprintf (fd, "User fit procedure pointer = %d\n") + call pargi (IN_UFIT (in)) + + # Minimum variable values. + if (IN_XMIN (in) != NULL) { + call fprintf (fd, "Minimum variable values (%d):\n") + call pargi (nvars) + do i = 1, nvars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call parg$t (Mem$t[IN_XMIN (in) + i - 1]) + } + } else + call fprintf (fd, "Null minimum value pointer\n") + call flush (fd) + + # Maximum variable values. + if (IN_XMAX (in) != NULL) { + call fprintf (fd, "Maximum variable values (%d):\n") + call pargi (nvars) + do i = 1, nvars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call parg$t (Mem$t[IN_XMAX (in) + i - 1]) + } + } else + call fprintf (fd, "Null maximum value pointer\n") + call flush (fd) + + # Flags. + call fprintf (fd, "Overplot next flag = %d\n") + call pargi (IN_OVERPLOT (in)) + call fprintf (fd, "Overplot fit flag = %d\n") + call pargi (IN_PLOTFIT (in)) + call fprintf (fd, "Fit error code = %d\n") + call pargi (IN_FITERROR (in)) + + # Strings. + if (IN_LABELS (in) != NULL) { + call fprintf (fd, "Axis labels = [%s]\n") + call pargstr (Memc[IN_LABELS (in)]) + } else + call fprintf (fd, "Null axis label pointer\n") + if (IN_UNITS (in) != NULL) { + call fprintf (fd, "Axis units = [%s]\n") + call pargstr (Memc[IN_UNITS (in)]) + } else + call fprintf (fd, "Null axis unit pointer\n") + if (IN_FLABELS (in) != NULL) { + call fprintf (fd, "Function/fit labels = [%s]\n") + call pargstr (Memc[IN_FLABELS (in)]) + } else + call fprintf (fd, "Null function/fit label pointer\n") + if (IN_FUNITS (in) != NULL) { + call fprintf (fd, "Function/fit units = [%s]\n") + call pargstr (Memc[IN_FUNITS (in)]) + } else + call fprintf (fd, "Null function/fit unit pointer\n") + if (IN_PLABELS (in) != NULL) { + call fprintf (fd, "Parameter labels = [%s]\n") + call pargstr (Memc[IN_PLABELS (in)]) + } else + call fprintf (fd, "Null parameter label pointer\n") + if (IN_PUNITS (in) != NULL) { + call fprintf (fd, "Parameter units = [%s]\n") + call pargstr (Memc[IN_PUNITS (in)]) + } else + call fprintf (fd, "Null parameter unit pointer\n") + if (IN_VLABELS (in) != NULL) { + call fprintf (fd, "Variable labels = [%s]\n") + call pargstr (Memc[IN_VLABELS (in)]) + } else + call fprintf (fd, "Null variable label pointer\n") + if (IN_VUNITS (in) != NULL) { + call fprintf (fd, "Variable units = [%s]\n") + call pargstr (Memc[IN_VUNITS (in)]) + } else + call fprintf (fd, "Null variable unit pointer\n") + if (IN_USERLABELS (in) != NULL) { + call fprintf (fd, "User plot labels = [%s]\n") + call pargstr (Memc[IN_USERLABELS (in)]) + } else + call fprintf (fd, "Null user plot label pointer\n") + if (IN_USERUNITS (in) != NULL) { + call fprintf (fd, "User plot units = [%s]\n") + call pargstr (Memc[IN_USERUNITS (in)]) + } else + call fprintf (fd, "Null user plot unit pointer\n") + if (IN_HELP (in) != NULL) { + call fprintf (fd, "Help page = [%s]\n") + call pargstr (Memc[IN_HELP (in)]) + } else + call fprintf (fd, "Null help page pointer\n") + if (IN_PROMPT (in) != NULL) { + call fprintf (fd, "Help prompt = [%s]\n") + call pargstr (Memc[IN_PROMPT (in)]) + } else + call fprintf (fd, "Null help prompt\n") + call flush (fd) + + # Graph keys. + if (IN_SGAXES (in) != NULL) { + call fprintf (fd, "Current graph key = %d\n") + call pargi (IN_GKEY (in)) + do i = 1, INLNGKEYS { + call fprintf (fd, "%d, xtype=%d, xnum=%d, ytype=%d, ynum=%d\n") + call pargi (i) + call pargi (IN_GXTYPE (in, i)) + call pargi (IN_GXNUMBER (in, i)) + call pargi (IN_GYTYPE (in, i)) + call pargi (IN_GYNUMBER (in, i)) + } + } else + call fprintf (fd, "Null key pointer\n") + call flush (fd) +end diff --git a/pkg/xtools/inlfit/indumpd.x b/pkg/xtools/inlfit/indumpd.x new file mode 100644 index 00000000..8e388f4a --- /dev/null +++ b/pkg/xtools/inlfit/indumpd.x @@ -0,0 +1,233 @@ +include <pkg/inlfit.h> +include "inlfitdef.h" + +# IN_DUMP -- INLFIT debugging routine. + +procedure in_dumpd (fd, in) + +int fd # file descriptor +pointer in # INLFIT descriptor + +int i, npars, nfpars, nvars + +begin + # Test INLFIT pointer. + if (in == NULL) { + call fprintf (fd, "\n****** in_dump: Null INLFIT pointer\n") + call flush (fd) + return + } + + # File and INLFIT descriptors. + call fprintf (fd, "\n****** in_dump: (fd=%d), (in=%d)\n") + call pargi (fd) + call pargi (in) + call flush (fd) + + # Function and derivative pointers. + call fprintf (fd, "Fitting function pointer = %d\n") + call pargi (IN_FUNC (in)) + call fprintf (fd, "Derivative function pointer = %d\n") + call pargi (IN_DFUNC (in)) + call flush (fd) + + # Number of parameters, fitting parameters, and variables. + npars = IN_NPARAMS (in) + nfpars = IN_NFPARAMS (in) + nvars = IN_NVARS (in) + call fprintf (fd, "Number of parameters = %d\n") + call pargi (npars) + call fprintf (fd, "Number of fitted parameters = %d\n") + call pargi (nfpars) + call fprintf (fd, "Number of variables = %d\n") + call pargi (nvars) + call fprintf (fd, "Number of points = %d\n") + call pargi (IN_NPTS (in)) + call flush (fd) + + # Parameter values. + call fprintf (fd, "Parameter values (%d):\n") + call pargi (npars) + if (IN_PARAM (in) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargd (Memd [IN_PARAM (in) + i - 1]) + } + } else + call fprintf (fd, "Null parameter value pointer\n") + call flush (fd) + + # Parameter changes. + if (IN_PARAM (in) != NULL) { + call fprintf (fd, "Parameter changes (%d):\n") + call pargi (npars) + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargd (Memd [IN_DPARAM (in) + i - 1]) + } + } else + call fprintf (fd, "Null parameter change pointer\n") + call flush (fd) + + # Parameter list. + if (IN_PARAM (in) != NULL) { + call fprintf (fd, "Parameter list (%d):\n") + call pargi (npars) + do i = 1, npars { + call fprintf (fd, "%d -> %d\n") + call pargi (i) + call pargi (Memi[IN_PLIST (in) + i - 1]) + } + } else + call fprintf (fd, "Null parameter list pointer\n") + call flush (fd) + + # Floating point parameters. + if (IN_SFLOAT (in) != NULL) { + call fprintf (fd, "Fit tolerance = %g\n") + call pargd (IN_TOLD (in)) + call fprintf (fd, "Low reject = %g\n") + call pargd (IN_LOWD (in)) + call fprintf (fd, "High reject = %g\n") + call pargd (IN_HIGHD (in)) + call fprintf (fd, "Growing radius = %g\n") + call pargd (IN_GROWD (in)) + } else + call fprintf (fd, "Null floating point pointer\n") + call flush (fd) + + # Max number of iterations, and rejection iterations. + call fprintf (fd, "Maximum number of iterations = %d\n") + call pargi (IN_MAXITER (in)) + call fprintf (fd, "Number of rejection iterations = %d\n") + call pargi (IN_MAXITER (in)) + + # Rejected points. + call fprintf (fd, "Number of rejected points = %d\n") + call pargi (IN_NREJPTS (in)) + call fprintf (fd, "Rejected point list pointer = %d\n") + call pargi (IN_REJPTS (in)) + + # User procedures. + call fprintf (fd, "User axis procedure pointer = %d\n") + call pargi (IN_UAXES (in)) + call fprintf (fd, "User colon procedure pointer = %d\n") + call pargi (IN_UCOLON (in)) + call fprintf (fd, "User fit procedure pointer = %d\n") + call pargi (IN_UFIT (in)) + + # Minimum variable values. + if (IN_XMIN (in) != NULL) { + call fprintf (fd, "Minimum variable values (%d):\n") + call pargi (nvars) + do i = 1, nvars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargd (Memd[IN_XMIN (in) + i - 1]) + } + } else + call fprintf (fd, "Null minimum value pointer\n") + call flush (fd) + + # Maximum variable values. + if (IN_XMAX (in) != NULL) { + call fprintf (fd, "Maximum variable values (%d):\n") + call pargi (nvars) + do i = 1, nvars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargd (Memd[IN_XMAX (in) + i - 1]) + } + } else + call fprintf (fd, "Null maximum value pointer\n") + call flush (fd) + + # Flags. + call fprintf (fd, "Overplot next flag = %d\n") + call pargi (IN_OVERPLOT (in)) + call fprintf (fd, "Overplot fit flag = %d\n") + call pargi (IN_PLOTFIT (in)) + call fprintf (fd, "Fit error code = %d\n") + call pargi (IN_FITERROR (in)) + + # Strings. + if (IN_LABELS (in) != NULL) { + call fprintf (fd, "Axis labels = [%s]\n") + call pargstr (Memc[IN_LABELS (in)]) + } else + call fprintf (fd, "Null axis label pointer\n") + if (IN_UNITS (in) != NULL) { + call fprintf (fd, "Axis units = [%s]\n") + call pargstr (Memc[IN_UNITS (in)]) + } else + call fprintf (fd, "Null axis unit pointer\n") + if (IN_FLABELS (in) != NULL) { + call fprintf (fd, "Function/fit labels = [%s]\n") + call pargstr (Memc[IN_FLABELS (in)]) + } else + call fprintf (fd, "Null function/fit label pointer\n") + if (IN_FUNITS (in) != NULL) { + call fprintf (fd, "Function/fit units = [%s]\n") + call pargstr (Memc[IN_FUNITS (in)]) + } else + call fprintf (fd, "Null function/fit unit pointer\n") + if (IN_PLABELS (in) != NULL) { + call fprintf (fd, "Parameter labels = [%s]\n") + call pargstr (Memc[IN_PLABELS (in)]) + } else + call fprintf (fd, "Null parameter label pointer\n") + if (IN_PUNITS (in) != NULL) { + call fprintf (fd, "Parameter units = [%s]\n") + call pargstr (Memc[IN_PUNITS (in)]) + } else + call fprintf (fd, "Null parameter unit pointer\n") + if (IN_VLABELS (in) != NULL) { + call fprintf (fd, "Variable labels = [%s]\n") + call pargstr (Memc[IN_VLABELS (in)]) + } else + call fprintf (fd, "Null variable label pointer\n") + if (IN_VUNITS (in) != NULL) { + call fprintf (fd, "Variable units = [%s]\n") + call pargstr (Memc[IN_VUNITS (in)]) + } else + call fprintf (fd, "Null variable unit pointer\n") + if (IN_USERLABELS (in) != NULL) { + call fprintf (fd, "User plot labels = [%s]\n") + call pargstr (Memc[IN_USERLABELS (in)]) + } else + call fprintf (fd, "Null user plot label pointer\n") + if (IN_USERUNITS (in) != NULL) { + call fprintf (fd, "User plot units = [%s]\n") + call pargstr (Memc[IN_USERUNITS (in)]) + } else + call fprintf (fd, "Null user plot unit pointer\n") + if (IN_HELP (in) != NULL) { + call fprintf (fd, "Help page = [%s]\n") + call pargstr (Memc[IN_HELP (in)]) + } else + call fprintf (fd, "Null help page pointer\n") + if (IN_PROMPT (in) != NULL) { + call fprintf (fd, "Help prompt = [%s]\n") + call pargstr (Memc[IN_PROMPT (in)]) + } else + call fprintf (fd, "Null help prompt\n") + call flush (fd) + + # Graph keys. + if (IN_SGAXES (in) != NULL) { + call fprintf (fd, "Current graph key = %d\n") + call pargi (IN_GKEY (in)) + do i = 1, INLNGKEYS { + call fprintf (fd, "%d, xtype=%d, xnum=%d, ytype=%d, ynum=%d\n") + call pargi (i) + call pargi (IN_GXTYPE (in, i)) + call pargi (IN_GXNUMBER (in, i)) + call pargi (IN_GYTYPE (in, i)) + call pargi (IN_GYNUMBER (in, i)) + } + } else + call fprintf (fd, "Null key pointer\n") + call flush (fd) +end diff --git a/pkg/xtools/inlfit/indumpr.x b/pkg/xtools/inlfit/indumpr.x new file mode 100644 index 00000000..bdcc6be7 --- /dev/null +++ b/pkg/xtools/inlfit/indumpr.x @@ -0,0 +1,233 @@ +include <pkg/inlfit.h> +include "inlfitdef.h" + +# IN_DUMP -- INLFIT debugging routine. + +procedure in_dumpr (fd, in) + +int fd # file descriptor +pointer in # INLFIT descriptor + +int i, npars, nfpars, nvars + +begin + # Test INLFIT pointer. + if (in == NULL) { + call fprintf (fd, "\n****** in_dump: Null INLFIT pointer\n") + call flush (fd) + return + } + + # File and INLFIT descriptors. + call fprintf (fd, "\n****** in_dump: (fd=%d), (in=%d)\n") + call pargi (fd) + call pargi (in) + call flush (fd) + + # Function and derivative pointers. + call fprintf (fd, "Fitting function pointer = %d\n") + call pargi (IN_FUNC (in)) + call fprintf (fd, "Derivative function pointer = %d\n") + call pargi (IN_DFUNC (in)) + call flush (fd) + + # Number of parameters, fitting parameters, and variables. + npars = IN_NPARAMS (in) + nfpars = IN_NFPARAMS (in) + nvars = IN_NVARS (in) + call fprintf (fd, "Number of parameters = %d\n") + call pargi (npars) + call fprintf (fd, "Number of fitted parameters = %d\n") + call pargi (nfpars) + call fprintf (fd, "Number of variables = %d\n") + call pargi (nvars) + call fprintf (fd, "Number of points = %d\n") + call pargi (IN_NPTS (in)) + call flush (fd) + + # Parameter values. + call fprintf (fd, "Parameter values (%d):\n") + call pargi (npars) + if (IN_PARAM (in) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargr (Memr [IN_PARAM (in) + i - 1]) + } + } else + call fprintf (fd, "Null parameter value pointer\n") + call flush (fd) + + # Parameter changes. + if (IN_PARAM (in) != NULL) { + call fprintf (fd, "Parameter changes (%d):\n") + call pargi (npars) + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargr (Memr [IN_DPARAM (in) + i - 1]) + } + } else + call fprintf (fd, "Null parameter change pointer\n") + call flush (fd) + + # Parameter list. + if (IN_PARAM (in) != NULL) { + call fprintf (fd, "Parameter list (%d):\n") + call pargi (npars) + do i = 1, npars { + call fprintf (fd, "%d -> %d\n") + call pargi (i) + call pargi (Memi[IN_PLIST (in) + i - 1]) + } + } else + call fprintf (fd, "Null parameter list pointer\n") + call flush (fd) + + # Floating point parameters. + if (IN_SFLOAT (in) != NULL) { + call fprintf (fd, "Fit tolerance = %g\n") + call pargr (IN_TOLR (in)) + call fprintf (fd, "Low reject = %g\n") + call pargr (IN_LOWR (in)) + call fprintf (fd, "High reject = %g\n") + call pargr (IN_HIGHR (in)) + call fprintf (fd, "Growing radius = %g\n") + call pargr (IN_GROWR (in)) + } else + call fprintf (fd, "Null floating point pointer\n") + call flush (fd) + + # Max number of iterations, and rejection iterations. + call fprintf (fd, "Maximum number of iterations = %d\n") + call pargi (IN_MAXITER (in)) + call fprintf (fd, "Number of rejection iterations = %d\n") + call pargi (IN_MAXITER (in)) + + # Rejected points. + call fprintf (fd, "Number of rejected points = %d\n") + call pargi (IN_NREJPTS (in)) + call fprintf (fd, "Rejected point list pointer = %d\n") + call pargi (IN_REJPTS (in)) + + # User procedures. + call fprintf (fd, "User axis procedure pointer = %d\n") + call pargi (IN_UAXES (in)) + call fprintf (fd, "User colon procedure pointer = %d\n") + call pargi (IN_UCOLON (in)) + call fprintf (fd, "User fit procedure pointer = %d\n") + call pargi (IN_UFIT (in)) + + # Minimum variable values. + if (IN_XMIN (in) != NULL) { + call fprintf (fd, "Minimum variable values (%d):\n") + call pargi (nvars) + do i = 1, nvars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargr (Memr[IN_XMIN (in) + i - 1]) + } + } else + call fprintf (fd, "Null minimum value pointer\n") + call flush (fd) + + # Maximum variable values. + if (IN_XMAX (in) != NULL) { + call fprintf (fd, "Maximum variable values (%d):\n") + call pargi (nvars) + do i = 1, nvars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargr (Memr[IN_XMAX (in) + i - 1]) + } + } else + call fprintf (fd, "Null maximum value pointer\n") + call flush (fd) + + # Flags. + call fprintf (fd, "Overplot next flag = %d\n") + call pargi (IN_OVERPLOT (in)) + call fprintf (fd, "Overplot fit flag = %d\n") + call pargi (IN_PLOTFIT (in)) + call fprintf (fd, "Fit error code = %d\n") + call pargi (IN_FITERROR (in)) + + # Strings. + if (IN_LABELS (in) != NULL) { + call fprintf (fd, "Axis labels = [%s]\n") + call pargstr (Memc[IN_LABELS (in)]) + } else + call fprintf (fd, "Null axis label pointer\n") + if (IN_UNITS (in) != NULL) { + call fprintf (fd, "Axis units = [%s]\n") + call pargstr (Memc[IN_UNITS (in)]) + } else + call fprintf (fd, "Null axis unit pointer\n") + if (IN_FLABELS (in) != NULL) { + call fprintf (fd, "Function/fit labels = [%s]\n") + call pargstr (Memc[IN_FLABELS (in)]) + } else + call fprintf (fd, "Null function/fit label pointer\n") + if (IN_FUNITS (in) != NULL) { + call fprintf (fd, "Function/fit units = [%s]\n") + call pargstr (Memc[IN_FUNITS (in)]) + } else + call fprintf (fd, "Null function/fit unit pointer\n") + if (IN_PLABELS (in) != NULL) { + call fprintf (fd, "Parameter labels = [%s]\n") + call pargstr (Memc[IN_PLABELS (in)]) + } else + call fprintf (fd, "Null parameter label pointer\n") + if (IN_PUNITS (in) != NULL) { + call fprintf (fd, "Parameter units = [%s]\n") + call pargstr (Memc[IN_PUNITS (in)]) + } else + call fprintf (fd, "Null parameter unit pointer\n") + if (IN_VLABELS (in) != NULL) { + call fprintf (fd, "Variable labels = [%s]\n") + call pargstr (Memc[IN_VLABELS (in)]) + } else + call fprintf (fd, "Null variable label pointer\n") + if (IN_VUNITS (in) != NULL) { + call fprintf (fd, "Variable units = [%s]\n") + call pargstr (Memc[IN_VUNITS (in)]) + } else + call fprintf (fd, "Null variable unit pointer\n") + if (IN_USERLABELS (in) != NULL) { + call fprintf (fd, "User plot labels = [%s]\n") + call pargstr (Memc[IN_USERLABELS (in)]) + } else + call fprintf (fd, "Null user plot label pointer\n") + if (IN_USERUNITS (in) != NULL) { + call fprintf (fd, "User plot units = [%s]\n") + call pargstr (Memc[IN_USERUNITS (in)]) + } else + call fprintf (fd, "Null user plot unit pointer\n") + if (IN_HELP (in) != NULL) { + call fprintf (fd, "Help page = [%s]\n") + call pargstr (Memc[IN_HELP (in)]) + } else + call fprintf (fd, "Null help page pointer\n") + if (IN_PROMPT (in) != NULL) { + call fprintf (fd, "Help prompt = [%s]\n") + call pargstr (Memc[IN_PROMPT (in)]) + } else + call fprintf (fd, "Null help prompt\n") + call flush (fd) + + # Graph keys. + if (IN_SGAXES (in) != NULL) { + call fprintf (fd, "Current graph key = %d\n") + call pargi (IN_GKEY (in)) + do i = 1, INLNGKEYS { + call fprintf (fd, "%d, xtype=%d, xnum=%d, ytype=%d, ynum=%d\n") + call pargi (i) + call pargi (IN_GXTYPE (in, i)) + call pargi (IN_GXNUMBER (in, i)) + call pargi (IN_GYTYPE (in, i)) + call pargi (IN_GYNUMBER (in, i)) + } + } else + call fprintf (fd, "Null key pointer\n") + call flush (fd) +end diff --git a/pkg/xtools/inlfit/inerrors.gx b/pkg/xtools/inlfit/inerrors.gx new file mode 100644 index 00000000..f21f805f --- /dev/null +++ b/pkg/xtools/inlfit/inerrors.gx @@ -0,0 +1,66 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + +# IN_ERRORS -- Compute the reduced chi-square of the fit and the +# parameter errors. This procedure must be used instead of nlerrors() +# because the weigths are changed during the data rejection process. +# If no data rejection is used, then both procedures are equivalent. + +procedure in_errors$t (in, nl, x, y, wts, npts, nvars, variance, chisqr, + scatter, rms, errors) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +PIXEL x[ARB] # Ordinates (npts * nvars) +PIXEL y[npts] # Data to be fit +PIXEL wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +PIXEL variance # variance of the fit (output) +PIXEL chisqr # reduced chi-squared of fit (output) +PIXEL scatter # additional scatter in equation +PIXEL rms # RMS of the fit (output) +PIXEL errors[ARB] # errors in coefficients (output) + +int i +PIXEL in_rms$t(), nlstat$t +pointer sp, fit, wts1, rejpts + +int in_geti() +pointer in_getp() + +begin +# # Debug. +# call eprintf ("in_errors: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + # Allocate memory for fit and weights. + call smark (sp) + call salloc (fit, npts, TY_PIXEL) + call salloc (wts1, npts, TY_PIXEL) + + # Set zero weight for rejeceted points. + call amov$t (wts, Mem$t[wts1], npts) + if (in_geti (in, INLNREJPTS) > 0) { + rejpts = in_getp (in, INLREJPTS) + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Mem$t[wts1+i-1] = PIXEL (0.0) + } + } + + # Evaluate the fit, and compute the rms, reduced chi + # squared and errors. + + call nlvector$t (nl, x, Mem$t[fit], npts, nvars) + call nlerrors$t (nl, y, Mem$t[fit], Mem$t[wts1], npts, + variance, chisqr, errors) + rms = in_rms$t (y, Mem$t[fit], Mem$t[wts1], npts) + scatter = nlstat$t (nl, NLSCATTER) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/inerrorsd.x b/pkg/xtools/inlfit/inerrorsd.x new file mode 100644 index 00000000..deae56d2 --- /dev/null +++ b/pkg/xtools/inlfit/inerrorsd.x @@ -0,0 +1,66 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + +# IN_ERRORS -- Compute the reduced chi-square of the fit and the +# parameter errors. This procedure must be used instead of nlerrors() +# because the weigths are changed during the data rejection process. +# If no data rejection is used, then both procedures are equivalent. + +procedure in_errorsd (in, nl, x, y, wts, npts, nvars, variance, chisqr, + scatter, rms, errors) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +double x[ARB] # Ordinates (npts * nvars) +double y[npts] # Data to be fit +double wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +double variance # variance of the fit (output) +double chisqr # reduced chi-squared of fit (output) +double scatter # additional scatter in equation +double rms # RMS of the fit (output) +double errors[ARB] # errors in coefficients (output) + +int i +double in_rmsd(), nlstatd +pointer sp, fit, wts1, rejpts + +int in_geti() +pointer in_getp() + +begin +# # Debug. +# call eprintf ("in_errors: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + # Allocate memory for fit and weights. + call smark (sp) + call salloc (fit, npts, TY_DOUBLE) + call salloc (wts1, npts, TY_DOUBLE) + + # Set zero weight for rejeceted points. + call amovd (wts, Memd[wts1], npts) + if (in_geti (in, INLNREJPTS) > 0) { + rejpts = in_getp (in, INLREJPTS) + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Memd[wts1+i-1] = double (0.0) + } + } + + # Evaluate the fit, and compute the rms, reduced chi + # squared and errors. + + call nlvectord (nl, x, Memd[fit], npts, nvars) + call nlerrorsd (nl, y, Memd[fit], Memd[wts1], npts, + variance, chisqr, errors) + rms = in_rmsd (y, Memd[fit], Memd[wts1], npts) + scatter = nlstatd (nl, NLSCATTER) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/inerrorsr.x b/pkg/xtools/inlfit/inerrorsr.x new file mode 100644 index 00000000..c481f565 --- /dev/null +++ b/pkg/xtools/inlfit/inerrorsr.x @@ -0,0 +1,66 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + +# IN_ERRORS -- Compute the reduced chi-square of the fit and the +# parameter errors. This procedure must be used instead of nlerrors() +# because the weigths are changed during the data rejection process. +# If no data rejection is used, then both procedures are equivalent. + +procedure in_errorsr (in, nl, x, y, wts, npts, nvars, variance, chisqr, + scatter, rms, errors) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +real x[ARB] # Ordinates (npts * nvars) +real y[npts] # Data to be fit +real wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +real variance # variance of the fit (output) +real chisqr # reduced chi-squared of fit (output) +real scatter # additional scatter in equation +real rms # RMS of the fit (output) +real errors[ARB] # errors in coefficients (output) + +int i +real in_rmsr(), nlstatr +pointer sp, fit, wts1, rejpts + +int in_geti() +pointer in_getp() + +begin +# # Debug. +# call eprintf ("in_errors: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + # Allocate memory for fit and weights. + call smark (sp) + call salloc (fit, npts, TY_REAL) + call salloc (wts1, npts, TY_REAL) + + # Set zero weight for rejeceted points. + call amovr (wts, Memr[wts1], npts) + if (in_geti (in, INLNREJPTS) > 0) { + rejpts = in_getp (in, INLREJPTS) + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Memr[wts1+i-1] = real (0.0) + } + } + + # Evaluate the fit, and compute the rms, reduced chi + # squared and errors. + + call nlvectorr (nl, x, Memr[fit], npts, nvars) + call nlerrorsr (nl, y, Memr[fit], Memr[wts1], npts, + variance, chisqr, errors) + rms = in_rmsr (y, Memr[fit], Memr[wts1], npts) + scatter = nlstatr (nl, NLSCATTER) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/infit.gx b/pkg/xtools/inlfit/infit.gx new file mode 100644 index 00000000..069bf584 --- /dev/null +++ b/pkg/xtools/inlfit/infit.gx @@ -0,0 +1,99 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + +# IN_FIT -- Fit a function using non-linear least squares. The function +# can have an arbitrary number of independent variables. This is the main +# entry point for the non-interactive part of the INLFIT package. + +procedure in_fit$t (in, nl, x, y, wts, npts, nvars, wtflag, stat) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +PIXEL x[ARB] # Ordinates (npts * nvars) +PIXEL y[npts] # Data to be fit +PIXEL wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +int wtflag # Type of weighting +int stat # Error code (output) + +int i, ndeleted +pointer sp, wts1, str +int in_geti() +PIXEL in_get$t + +begin + +# # Debug. +# call eprintf ("in_fit: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + # Allocate string, and rejection weight space. The latter are + # are used to mark rejected points with a zero weight before + # calling NLFIT. + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (wts1, npts, TY_PIXEL) + call amov$t (wts, Mem$t[wts1], npts) + + # Initialize rejected point list, and the buffer containing + # the minimum and maximum variable values. + call in_bfinit$t (in, npts, nvars) + + # Set independent variable limits. + call in_limit$t (in, x, npts, nvars) + + # Reinitialize. + call in_nlinit$t (in, nl) + + # Check number of data points. If no points are present + # set the error flag to the appropiate value, and return. + if (npts == 0) { + stat = NO_DEG_FREEDOM + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + call sfree (sp) + return + } + + # Check the number of deleted points. + ndeleted = 0 + do i = 1, npts { + if (wts[i] <= PIXEL(0.0)) + ndeleted = ndeleted + 1 + } + if ((npts - ndeleted) < in_geti (in, INLNFPARAMS)) { + stat = NO_DEG_FREEDOM + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + call sfree (sp) + return + } + + # Call NLFIT. + call nlfit$t (nl, x, y, wts, npts, nvars, wtflag, stat) + + # Update fit status into the INLFIT structure. + call in_puti (in, INLFITERROR, stat) + + # Do pixel rejection and refit, if at least one of the rejection + # limits is positive. Otherwise clear number of rejected points. + + if (in_get$t (in, INLLOW) > PIXEL (0.0) || + in_get$t (in, INLHIGH) > PIXEL (0.0)) { + call in_reject$t (in, nl, x, y, Mem$t[wts1], npts, nvars, wtflag) + if (in_geti (in, INLNREJPTS) > 0) { + do i = 1, npts { + if (Mem$t[wts1+i-1] > PIXEL(0.0)) + wts[i] = Mem$t[wts1+i-1] + } + } + stat = in_geti (in, INLFITERROR) + } else + call in_puti (in, INLNREJPTS, 0) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/infitd.x b/pkg/xtools/inlfit/infitd.x new file mode 100644 index 00000000..f57bbb6c --- /dev/null +++ b/pkg/xtools/inlfit/infitd.x @@ -0,0 +1,99 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + +# IN_FIT -- Fit a function using non-linear least squares. The function +# can have an arbitrary number of independent variables. This is the main +# entry point for the non-interactive part of the INLFIT package. + +procedure in_fitd (in, nl, x, y, wts, npts, nvars, wtflag, stat) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +double x[ARB] # Ordinates (npts * nvars) +double y[npts] # Data to be fit +double wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +int wtflag # Type of weighting +int stat # Error code (output) + +int i, ndeleted +pointer sp, wts1, str +int in_geti() +double in_getd + +begin + +# # Debug. +# call eprintf ("in_fit: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + # Allocate string, and rejection weight space. The latter are + # are used to mark rejected points with a zero weight before + # calling NLFIT. + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (wts1, npts, TY_DOUBLE) + call amovd (wts, Memd[wts1], npts) + + # Initialize rejected point list, and the buffer containing + # the minimum and maximum variable values. + call in_bfinitd (in, npts, nvars) + + # Set independent variable limits. + call in_limitd (in, x, npts, nvars) + + # Reinitialize. + call in_nlinitd (in, nl) + + # Check number of data points. If no points are present + # set the error flag to the appropiate value, and return. + if (npts == 0) { + stat = NO_DEG_FREEDOM + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + call sfree (sp) + return + } + + # Check the number of deleted points. + ndeleted = 0 + do i = 1, npts { + if (wts[i] <= double(0.0)) + ndeleted = ndeleted + 1 + } + if ((npts - ndeleted) < in_geti (in, INLNFPARAMS)) { + stat = NO_DEG_FREEDOM + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + call sfree (sp) + return + } + + # Call NLFIT. + call nlfitd (nl, x, y, wts, npts, nvars, wtflag, stat) + + # Update fit status into the INLFIT structure. + call in_puti (in, INLFITERROR, stat) + + # Do pixel rejection and refit, if at least one of the rejection + # limits is positive. Otherwise clear number of rejected points. + + if (in_getd (in, INLLOW) > double (0.0) || + in_getd (in, INLHIGH) > double (0.0)) { + call in_rejectd (in, nl, x, y, Memd[wts1], npts, nvars, wtflag) + if (in_geti (in, INLNREJPTS) > 0) { + do i = 1, npts { + if (Memd[wts1+i-1] > double(0.0)) + wts[i] = Memd[wts1+i-1] + } + } + stat = in_geti (in, INLFITERROR) + } else + call in_puti (in, INLNREJPTS, 0) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/infitr.x b/pkg/xtools/inlfit/infitr.x new file mode 100644 index 00000000..1a46a09c --- /dev/null +++ b/pkg/xtools/inlfit/infitr.x @@ -0,0 +1,99 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + +# IN_FIT -- Fit a function using non-linear least squares. The function +# can have an arbitrary number of independent variables. This is the main +# entry point for the non-interactive part of the INLFIT package. + +procedure in_fitr (in, nl, x, y, wts, npts, nvars, wtflag, stat) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +real x[ARB] # Ordinates (npts * nvars) +real y[npts] # Data to be fit +real wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +int wtflag # Type of weighting +int stat # Error code (output) + +int i, ndeleted +pointer sp, wts1, str +int in_geti() +real in_getr + +begin + +# # Debug. +# call eprintf ("in_fit: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + # Allocate string, and rejection weight space. The latter are + # are used to mark rejected points with a zero weight before + # calling NLFIT. + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (wts1, npts, TY_REAL) + call amovr (wts, Memr[wts1], npts) + + # Initialize rejected point list, and the buffer containing + # the minimum and maximum variable values. + call in_bfinitr (in, npts, nvars) + + # Set independent variable limits. + call in_limitr (in, x, npts, nvars) + + # Reinitialize. + call in_nlinitr (in, nl) + + # Check number of data points. If no points are present + # set the error flag to the appropiate value, and return. + if (npts == 0) { + stat = NO_DEG_FREEDOM + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + call sfree (sp) + return + } + + # Check the number of deleted points. + ndeleted = 0 + do i = 1, npts { + if (wts[i] <= real(0.0)) + ndeleted = ndeleted + 1 + } + if ((npts - ndeleted) < in_geti (in, INLNFPARAMS)) { + stat = NO_DEG_FREEDOM + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + call sfree (sp) + return + } + + # Call NLFIT. + call nlfitr (nl, x, y, wts, npts, nvars, wtflag, stat) + + # Update fit status into the INLFIT structure. + call in_puti (in, INLFITERROR, stat) + + # Do pixel rejection and refit, if at least one of the rejection + # limits is positive. Otherwise clear number of rejected points. + + if (in_getr (in, INLLOW) > real (0.0) || + in_getr (in, INLHIGH) > real (0.0)) { + call in_rejectr (in, nl, x, y, Memr[wts1], npts, nvars, wtflag) + if (in_geti (in, INLNREJPTS) > 0) { + do i = 1, npts { + if (Memr[wts1+i-1] > real(0.0)) + wts[i] = Memr[wts1+i-1] + } + } + stat = in_geti (in, INLFITERROR) + } else + call in_puti (in, INLNREJPTS, 0) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/infree.gx b/pkg/xtools/inlfit/infree.gx new file mode 100644 index 00000000..80fed996 --- /dev/null +++ b/pkg/xtools/inlfit/infree.gx @@ -0,0 +1,52 @@ +include "inlfitdef.h" + + +# IN_FREE -- Free INLFIT parameter structure, substructures, and auxiliary +# buffers. + +procedure in_free$t (in) + +pointer in # INLFIT pointer + +begin + +# # Debug. +# call eprintf ("in_free: in=%d\n") +# call pargi (in) + + # Free only if it's not NULL. + if (in != NULL) { + + # Free parameter values, changes, and list. + call mfree (IN_PARAM (in), TY_PIXEL) + call mfree (IN_DPARAM (in), TY_PIXEL) + call mfree (IN_PLIST (in), TY_INT) + + # Free string space. + call mfree (IN_LABELS (in), TY_CHAR) + call mfree (IN_UNITS (in), TY_CHAR) + call mfree (IN_PLABELS (in), TY_CHAR) + call mfree (IN_PUNITS (in), TY_CHAR) + call mfree (IN_VLABELS (in), TY_CHAR) + call mfree (IN_VUNITS (in), TY_CHAR) + call mfree (IN_USERLABELS (in), TY_CHAR) + call mfree (IN_USERUNITS (in), TY_CHAR) + call mfree (IN_HELP (in), TY_CHAR) + call mfree (IN_PROMPT (in), TY_CHAR) + + # Free rejected point list, and limit values for variables. + if (IN_REJPTS (in) != NULL) + call mfree (IN_REJPTS (in), TY_INT) + if (IN_XMIN (in) != NULL) + call mfree (IN_XMIN (in), TY_PIXEL) + if (IN_XMAX (in) != NULL) + call mfree (IN_XMAX (in), TY_PIXEL) + + # Free substructures. + call mfree (IN_SFLOAT (in), TY_PIXEL) + call mfree (IN_SGAXES (in), TY_INT) + + # Free structure. + call mfree (in, TY_STRUCT) + } +end diff --git a/pkg/xtools/inlfit/infreed.x b/pkg/xtools/inlfit/infreed.x new file mode 100644 index 00000000..09f2c8ea --- /dev/null +++ b/pkg/xtools/inlfit/infreed.x @@ -0,0 +1,52 @@ +include "inlfitdef.h" + + +# IN_FREE -- Free INLFIT parameter structure, substructures, and auxiliary +# buffers. + +procedure in_freed (in) + +pointer in # INLFIT pointer + +begin + +# # Debug. +# call eprintf ("in_free: in=%d\n") +# call pargi (in) + + # Free only if it's not NULL. + if (in != NULL) { + + # Free parameter values, changes, and list. + call mfree (IN_PARAM (in), TY_DOUBLE) + call mfree (IN_DPARAM (in), TY_DOUBLE) + call mfree (IN_PLIST (in), TY_INT) + + # Free string space. + call mfree (IN_LABELS (in), TY_CHAR) + call mfree (IN_UNITS (in), TY_CHAR) + call mfree (IN_PLABELS (in), TY_CHAR) + call mfree (IN_PUNITS (in), TY_CHAR) + call mfree (IN_VLABELS (in), TY_CHAR) + call mfree (IN_VUNITS (in), TY_CHAR) + call mfree (IN_USERLABELS (in), TY_CHAR) + call mfree (IN_USERUNITS (in), TY_CHAR) + call mfree (IN_HELP (in), TY_CHAR) + call mfree (IN_PROMPT (in), TY_CHAR) + + # Free rejected point list, and limit values for variables. + if (IN_REJPTS (in) != NULL) + call mfree (IN_REJPTS (in), TY_INT) + if (IN_XMIN (in) != NULL) + call mfree (IN_XMIN (in), TY_DOUBLE) + if (IN_XMAX (in) != NULL) + call mfree (IN_XMAX (in), TY_DOUBLE) + + # Free substructures. + call mfree (IN_SFLOAT (in), TY_DOUBLE) + call mfree (IN_SGAXES (in), TY_INT) + + # Free structure. + call mfree (in, TY_STRUCT) + } +end diff --git a/pkg/xtools/inlfit/infreer.x b/pkg/xtools/inlfit/infreer.x new file mode 100644 index 00000000..55136dfd --- /dev/null +++ b/pkg/xtools/inlfit/infreer.x @@ -0,0 +1,52 @@ +include "inlfitdef.h" + + +# IN_FREE -- Free INLFIT parameter structure, substructures, and auxiliary +# buffers. + +procedure in_freer (in) + +pointer in # INLFIT pointer + +begin + +# # Debug. +# call eprintf ("in_free: in=%d\n") +# call pargi (in) + + # Free only if it's not NULL. + if (in != NULL) { + + # Free parameter values, changes, and list. + call mfree (IN_PARAM (in), TY_REAL) + call mfree (IN_DPARAM (in), TY_REAL) + call mfree (IN_PLIST (in), TY_INT) + + # Free string space. + call mfree (IN_LABELS (in), TY_CHAR) + call mfree (IN_UNITS (in), TY_CHAR) + call mfree (IN_PLABELS (in), TY_CHAR) + call mfree (IN_PUNITS (in), TY_CHAR) + call mfree (IN_VLABELS (in), TY_CHAR) + call mfree (IN_VUNITS (in), TY_CHAR) + call mfree (IN_USERLABELS (in), TY_CHAR) + call mfree (IN_USERUNITS (in), TY_CHAR) + call mfree (IN_HELP (in), TY_CHAR) + call mfree (IN_PROMPT (in), TY_CHAR) + + # Free rejected point list, and limit values for variables. + if (IN_REJPTS (in) != NULL) + call mfree (IN_REJPTS (in), TY_INT) + if (IN_XMIN (in) != NULL) + call mfree (IN_XMIN (in), TY_REAL) + if (IN_XMAX (in) != NULL) + call mfree (IN_XMAX (in), TY_REAL) + + # Free substructures. + call mfree (IN_SFLOAT (in), TY_REAL) + call mfree (IN_SGAXES (in), TY_INT) + + # Free structure. + call mfree (in, TY_STRUCT) + } +end diff --git a/pkg/xtools/inlfit/ingaxes.gx b/pkg/xtools/inlfit/ingaxes.gx new file mode 100644 index 00000000..d836e074 --- /dev/null +++ b/pkg/xtools/inlfit/ingaxes.gx @@ -0,0 +1,105 @@ +include <pkg/gtools.h> +include <pkg/inlfit.h> + +# ING_AXES -- Set axes data. The applications program may set additional +# axes types. + +procedure ing_axes$t (in, gt, nl, axis, x, y, z, npts, nvars) + +pointer in # INLFIT pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +int axis # Output axis +PIXEL x[ARB] # Independent variables (npts * nvars) +PIXEL y[npts] # Dependent variable +PIXEL z[npts] # Output values +int npts # Number of points +int nvars # Number of variables + +int i, j +int axistype, axisnum +int gtlabel[2], gtunits[2] +PIXEL a, b, xmin, xmax +pointer sp, label, units, minptr, maxptr + +PIXEL nleval$t() +PIXEL ing_dvz$t() +errchk adiv$t() +extern ing_dvz$t() + +data gtlabel/GTXLABEL, GTYLABEL/ +data gtunits/GTXUNITS, GTYUNITS/ + +int in_geti() +pointer in_getp() + +begin + # Allocate string space. + call smark (sp) + call salloc (label, SZ_LINE, TY_CHAR) + call salloc (units, SZ_LINE, TY_CHAR) + + # Get the appropiate axis type and variable number. + call in_gkey (in, in_geti (in, INLGKEY), axis, axistype, axisnum) + + # Get and set axes labels and units. + call ing_getlabel (in, axistype, axisnum, Memc[label], Memc[units], + SZ_LINE) + call gt_sets (gt, gtlabel[axis], Memc[label]) + call gt_sets (gt, gtunits[axis], Memc[units]) + + # Branch on axis type. + switch (axistype) { + case KEY_VARIABLE: # Independent variable + do i = 1, npts + z[i] = x[(i-1)*nvars+axisnum] + case KEY_FUNCTION: # Function variable + call amov$t (y, z, npts) + case KEY_FIT: # Fitted values + call nlvector$t (nl, x, z, npts, nvars) + case KEY_RESIDUALS: # Residuals + call nlvector$t (nl, x, z, npts, nvars) + call asub$t (y, z, z, npts) + case KEY_RATIO: # Ratio + call nlvector$t (nl, x, z, npts, nvars) + call advz$t (y, z, z, npts, ing_dvz$t) + case KEY_NONLINEAR: # Linear component removed + call aclr$t (z, npts) + minptr = in_getp (in, INLXMIN) + maxptr = in_getp (in, INLXMAX) + a = nleval$t (nl, Mem$t[minptr], nvars) + do i = 1, nvars { + xmin = Mem$t[minptr+i-1] + xmax = Mem$t[maxptr+i-1] + Mem$t[minptr+i-1] = xmax + b = (nleval$t (nl, Mem$t[minptr], nvars) - a) / + (xmax - xmin) + Mem$t[minptr+i-1] = xmin + do j = 1, npts + z[j] = z[j] + y[j] - a - b * (x[(j-1)*nvars+i] - xmin) + } + case KEY_UAXIS: # User axes plots. + if (axis == 1) { + do i = 1, npts + z[i] = x[(i-1)*nvars+axisnum] + } else + call amov$t (y, z, npts) + call ing_uaxes$t (axisnum, in, nl, x, y, z, npts, nvars) + default: + call error (0, "ing_axes: Unknown axis type") + } + + # Free memory. + call sfree (sp) +end + + +# ING_DVZ -- Error action to take on zero division. + +PIXEL procedure ing_dvz$t (x) + +PIXEL x # Numerator + +begin + return (PIXEL (1.0)) +end diff --git a/pkg/xtools/inlfit/ingaxesd.x b/pkg/xtools/inlfit/ingaxesd.x new file mode 100644 index 00000000..9a9816a6 --- /dev/null +++ b/pkg/xtools/inlfit/ingaxesd.x @@ -0,0 +1,105 @@ +include <pkg/gtools.h> +include <pkg/inlfit.h> + +# ING_AXES -- Set axes data. The applications program may set additional +# axes types. + +procedure ing_axesd (in, gt, nl, axis, x, y, z, npts, nvars) + +pointer in # INLFIT pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +int axis # Output axis +double x[ARB] # Independent variables (npts * nvars) +double y[npts] # Dependent variable +double z[npts] # Output values +int npts # Number of points +int nvars # Number of variables + +int i, j +int axistype, axisnum +int gtlabel[2], gtunits[2] +double a, b, xmin, xmax +pointer sp, label, units, minptr, maxptr + +double nlevald() +double ing_dvzd() +errchk adivd() +extern ing_dvzd() + +data gtlabel/GTXLABEL, GTYLABEL/ +data gtunits/GTXUNITS, GTYUNITS/ + +int in_geti() +pointer in_getp() + +begin + # Allocate string space. + call smark (sp) + call salloc (label, SZ_LINE, TY_CHAR) + call salloc (units, SZ_LINE, TY_CHAR) + + # Get the appropiate axis type and variable number. + call in_gkey (in, in_geti (in, INLGKEY), axis, axistype, axisnum) + + # Get and set axes labels and units. + call ing_getlabel (in, axistype, axisnum, Memc[label], Memc[units], + SZ_LINE) + call gt_sets (gt, gtlabel[axis], Memc[label]) + call gt_sets (gt, gtunits[axis], Memc[units]) + + # Branch on axis type. + switch (axistype) { + case KEY_VARIABLE: # Independent variable + do i = 1, npts + z[i] = x[(i-1)*nvars+axisnum] + case KEY_FUNCTION: # Function variable + call amovd (y, z, npts) + case KEY_FIT: # Fitted values + call nlvectord (nl, x, z, npts, nvars) + case KEY_RESIDUALS: # Residuals + call nlvectord (nl, x, z, npts, nvars) + call asubd (y, z, z, npts) + case KEY_RATIO: # Ratio + call nlvectord (nl, x, z, npts, nvars) + call advzd (y, z, z, npts, ing_dvzd) + case KEY_NONLINEAR: # Linear component removed + call aclrd (z, npts) + minptr = in_getp (in, INLXMIN) + maxptr = in_getp (in, INLXMAX) + a = nlevald (nl, Memd[minptr], nvars) + do i = 1, nvars { + xmin = Memd[minptr+i-1] + xmax = Memd[maxptr+i-1] + Memd[minptr+i-1] = xmax + b = (nlevald (nl, Memd[minptr], nvars) - a) / + (xmax - xmin) + Memd[minptr+i-1] = xmin + do j = 1, npts + z[j] = z[j] + y[j] - a - b * (x[(j-1)*nvars+i] - xmin) + } + case KEY_UAXIS: # User axes plots. + if (axis == 1) { + do i = 1, npts + z[i] = x[(i-1)*nvars+axisnum] + } else + call amovd (y, z, npts) + call ing_uaxesd (axisnum, in, nl, x, y, z, npts, nvars) + default: + call error (0, "ing_axes: Unknown axis type") + } + + # Free memory. + call sfree (sp) +end + + +# ING_DVZ -- Error action to take on zero division. + +double procedure ing_dvzd (x) + +double x # Numerator + +begin + return (double (1.0)) +end diff --git a/pkg/xtools/inlfit/ingaxesr.x b/pkg/xtools/inlfit/ingaxesr.x new file mode 100644 index 00000000..5af7f3d8 --- /dev/null +++ b/pkg/xtools/inlfit/ingaxesr.x @@ -0,0 +1,105 @@ +include <pkg/gtools.h> +include <pkg/inlfit.h> + +# ING_AXES -- Set axes data. The applications program may set additional +# axes types. + +procedure ing_axesr (in, gt, nl, axis, x, y, z, npts, nvars) + +pointer in # INLFIT pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +int axis # Output axis +real x[ARB] # Independent variables (npts * nvars) +real y[npts] # Dependent variable +real z[npts] # Output values +int npts # Number of points +int nvars # Number of variables + +int i, j +int axistype, axisnum +int gtlabel[2], gtunits[2] +real a, b, xmin, xmax +pointer sp, label, units, minptr, maxptr + +real nlevalr() +real ing_dvzr() +errchk adivr() +extern ing_dvzr() + +data gtlabel/GTXLABEL, GTYLABEL/ +data gtunits/GTXUNITS, GTYUNITS/ + +int in_geti() +pointer in_getp() + +begin + # Allocate string space. + call smark (sp) + call salloc (label, SZ_LINE, TY_CHAR) + call salloc (units, SZ_LINE, TY_CHAR) + + # Get the appropiate axis type and variable number. + call in_gkey (in, in_geti (in, INLGKEY), axis, axistype, axisnum) + + # Get and set axes labels and units. + call ing_getlabel (in, axistype, axisnum, Memc[label], Memc[units], + SZ_LINE) + call gt_sets (gt, gtlabel[axis], Memc[label]) + call gt_sets (gt, gtunits[axis], Memc[units]) + + # Branch on axis type. + switch (axistype) { + case KEY_VARIABLE: # Independent variable + do i = 1, npts + z[i] = x[(i-1)*nvars+axisnum] + case KEY_FUNCTION: # Function variable + call amovr (y, z, npts) + case KEY_FIT: # Fitted values + call nlvectorr (nl, x, z, npts, nvars) + case KEY_RESIDUALS: # Residuals + call nlvectorr (nl, x, z, npts, nvars) + call asubr (y, z, z, npts) + case KEY_RATIO: # Ratio + call nlvectorr (nl, x, z, npts, nvars) + call advzr (y, z, z, npts, ing_dvzr) + case KEY_NONLINEAR: # Linear component removed + call aclrr (z, npts) + minptr = in_getp (in, INLXMIN) + maxptr = in_getp (in, INLXMAX) + a = nlevalr (nl, Memr[minptr], nvars) + do i = 1, nvars { + xmin = Memr[minptr+i-1] + xmax = Memr[maxptr+i-1] + Memr[minptr+i-1] = xmax + b = (nlevalr (nl, Memr[minptr], nvars) - a) / + (xmax - xmin) + Memr[minptr+i-1] = xmin + do j = 1, npts + z[j] = z[j] + y[j] - a - b * (x[(j-1)*nvars+i] - xmin) + } + case KEY_UAXIS: # User axes plots. + if (axis == 1) { + do i = 1, npts + z[i] = x[(i-1)*nvars+axisnum] + } else + call amovr (y, z, npts) + call ing_uaxesr (axisnum, in, nl, x, y, z, npts, nvars) + default: + call error (0, "ing_axes: Unknown axis type") + } + + # Free memory. + call sfree (sp) +end + + +# ING_DVZ -- Error action to take on zero division. + +real procedure ing_dvzr (x) + +real x # Numerator + +begin + return (real (1.0)) +end diff --git a/pkg/xtools/inlfit/ingcolon.gx b/pkg/xtools/inlfit/ingcolon.gx new file mode 100644 index 00000000..5b9f7bfb --- /dev/null +++ b/pkg/xtools/inlfit/ingcolon.gx @@ -0,0 +1,362 @@ +include <gset.h> +include <error.h> +include <pkg/inlfit.h> + +# List of colon commands. +define CMDS "|show|low_reject|high_reject|nreject|grow|errors|vshow|constant|\ +fit|tolerance|maxiter|variables|data|page|results|" + +define SHOW 1 # Show fit information +define LOW_REJECT 2 # Set or show lower rejection factor +define HIGH_REJECT 3 # Set or show upper rejection factor +define NREJECT 4 # Set or show rejection iterations +define GROW 5 # Set or show rejection growing radius +define ERRORS 6 # Show fit errors +define VSHOW 7 # Show verbose information +define CONSTANT 8 # Set constant parameter +define FIT 9 # Set fitting parameter +define TOL 10 # Set or show fitting tolerance +define MAXITER 11 # Set or show max number of iterations +define VARIABLES 12 # List the variables +define DATA 13 # List of data +define PAGE 14 # Page through a file +define RESULTS 15 # List the results of the fit + + +# ING_COLON -- Processes colon commands. The common flags and newgraph +# signal changes in fitting parameters or the need to redraw the graph. + +procedure ing_colon$t (in, cmdstr, gp, gt, nl, x, y, wts, names, npts, nvars, + len_name, newgraph) + +pointer in # INLFIT pointer +char cmdstr[ARB] # Command string +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer for error listing +PIXEL x[ARB] # Independent variabels (npts * nvars) +PIXEL y[npts] # dependent variables +PIXEL wts[npts] # Weights +char names[ARB] # Object names +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of object name +int newgraph # New graph ? + +int ncmd, ival +PIXEL fval +pointer sp, cmd + +int nscan(), strdic() +int in_geti() +PIXEL in_get$t() + +begin + # Allocate string space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Use formated scan to parse the command string. + # The first word is the command and it may be minimum match + # abbreviated with the list of commands. + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, CMDS) + + # Branch on command code. + switch (ncmd) { + case SHOW: # :show - Show the values of the fitting parameters. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_show$t (in, "STDOUT") + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_show$t (in, Memc[cmd]) + } then + call erract (EA_WARN) + } + + case LOW_REJECT: # :low_reject - List or set lower rejection factor. + call garg$t (fval) + if (nscan() == 1) { + call printf ("low_reject = %g\n") + call parg$t (in_get$t (in, INLLOW)) + } else + call in_put$t (in, INLLOW, fval) + + case HIGH_REJECT: # :high_reject - List or set high rejection factor. + call garg$t (fval) + if (nscan() == 1) { + call printf ("high_reject = %g\n") + call parg$t (in_get$t (in, INLHIGH)) + } else + call in_put$t (in, INLHIGH, fval) + + case NREJECT: # :nreject - List or set the rejection iterations. + call gargi (ival) + if (nscan() == 1) { + call printf ("nreject = %d\n") + call pargi (in_geti (in, INLNREJECT)) + } else + call in_puti (in, INLNREJECT, ival) + + case GROW: # :grow - List or set the rejection growing. + call garg$t (fval) + if (nscan() == 1) { + call printf ("grow = %g\n") + call parg$t (in_get$t (in, INLGROW)) + } else + call in_put$t (in, INLGROW, fval) + + case ERRORS: # :errors - print errors analysis of fit + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_show$t (in, "STDOUT") + call ing_errors$t (in, "STDOUT", nl, x, y, wts, npts, nvars) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_show$t (in, Memc[cmd]) + call ing_errors$t (in, Memc[cmd], nl, x, y, wts, npts, + nvars) + } then + call erract (EA_WARN) + } + + case VSHOW: # Verbose list of the fitting parameters and results. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_vshow$t (in, "STDOUT", nl, x, y, wts, names, npts, + nvars, len_name, gt) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_vshow$t (in, Memc[cmd], nl, x, y, wts, names, + npts, nvars, len_name, gt) + } then + call erract (EA_WARN) + } + + case CONSTANT: # Set constant parameter. + call ing_change$t (in, CONSTANT) + + case FIT: # Set fitting parameter. + call ing_change$t (in, FIT) + + case TOL: # Set or show tolerance. + call garg$t (fval) + if (nscan() == 1) { + call printf ("tol = %g\n") + call parg$t (in_get$t (in, INLTOLERANCE)) + } else + call in_put$t (in, INLTOLERANCE, fval) + + case MAXITER: # Set or show max number of iterations. + call gargi (ival) + if (nscan() == 1) { + call printf ("maxiter = %d\n") + call pargi (in_geti (in, INLMAXITER)) + } else + call in_puti (in, INLMAXITER, ival) + + case VARIABLES: # Show the list of variables. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_variables$t (in, "STDOUT", nvars) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_variables$t (in, Memc[cmd], nvars) + } then + call erract (EA_WARN) + } + + case DATA: # List the raw data. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_data$t (in, "STDOUT", x, names, npts, nvars, len_name) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_data$t (in, Memc[cmd], x, names, npts, nvars, + len_name) + } then + call erract (EA_WARN) + } + + case PAGE: # Page through a file. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) + call printf ("File to be paged is undefined\n") + else + call gpagefile (gp, Memc[cmd], "") + + case RESULTS: # List the results of the fit. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_results$t (in, "STDOUT", nl, x, y, wts, names, npts, + nvars, len_name) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_results$t (in, Memc[cmd], nl, x, y, wts, names, + npts, nvars, len_name) + } then + call erract (EA_WARN) + } + + default: # User definable action. + call ing_ucolon$t (in, gp, gt, nl, x, y, wts, npts, nvars, newgraph) + } + + # Free memory + call sfree (sp) +end + + +# ING_CHANGE -- Change fitting parameter into constant parameter, and +# viceversa. Parameters can be specified either by a name, supplied in +# the parameter labels, or just by a sequence number. + +procedure ing_change$t (in, type) + +pointer in # INLFIT descriptor +int type # parameter type (fit, constant) + +bool isfit +int ip, pos, number, npars +PIXEL $tval +pointer param, value, pname +pointer pvalues, plist, plabels +pointer sp + +bool streq() +int ctoi(), cto$t() +int strdic() +int in_geti() +pointer in_getp() + +begin + # Allocate string space. + call smark (sp) + call salloc (param, SZ_LINE, TY_CHAR) + call salloc (value, SZ_LINE, TY_CHAR) + call salloc (pname, SZ_LINE, TY_CHAR) + call salloc (plabels, SZ_LINE, TY_CHAR) + + # Get parameter name. + Memc[param] = EOS + call gargwrd (Memc[param], SZ_LINE) + if (streq (Memc[param], "")) { + call eprintf ("Parameter not specified\n") + call sfree (sp) + return + } + + # Try to find the parameter name in the parameter labels. + call in_gstr (in, INLPLABELS, Memc[plabels], SZ_LINE) + number = strdic (Memc[param], Memc[pname], SZ_LINE, Memc[plabels]) + + # Try to find the parameter by number if it was not found + # by name in the dictionary. + if (number == 0) { + ip = 1 + if (ctoi (Memc[param], ip, number) == 0) { + call eprintf ("Parameter not found (%s)\n") + call pargstr (Memc[param]) + call sfree (sp) + return + } + } + + # Test parameter number. + npars = in_geti (in, INLNPARAMS) + if (number < 1 || number > npars) { + call eprintf ("Parameter out of range (%d)\n") + call pargi (number) + call sfree (sp) + return + } + + # Get pointers to parameter values and list. + pvalues = in_getp (in, INLPARAM) + plist = in_getp (in, INLPLIST) + + # Get new value if specified. Otherwise assume + # old parameter value. + Memc[value] = EOS + call gargwrd (Memc[value], SZ_LINE) + if (streq (Memc[value], "")) + $tval = Mem$t[pvalues + number - 1] + else { + ip = 1 + if (cto$t (Memc[value], ip, $tval) == 0) { + call eprintf ("Bad parameter value (%s)\n") + call pargstr (Memc[value]) + call sfree (sp) + return + } + } + + # Update parameter value. + Mem$t[pvalues + number - 1] = $tval + + # Find the parameter position in the parameter list. + do pos = 1, npars { + if (Memi[plist + pos - 1] >= number || + Memi[plist + pos - 1] == 0) + break + } + + # Insert or remove parameter from the parameter list + # according with its type, i.e., with the type of change. + # The list is not changed if it's not necesary to do so. + + if (type == FIT) { + if (Memi[plist + pos - 1] != number) { + do ip = npars, pos + 1, -1 + Memi[plist + ip - 1] = Memi[plist + ip - 2] + Memi[plist + pos - 1] = number + call in_puti (in, INLNFPARAMS, in_geti (in, INLNFPARAMS) + 1) + } + isfit = true + } else { + if (Memi[plist + pos - 1] == number) { + do ip = pos, npars - 1 + Memi[plist + ip - 1] = Memi[plist + ip] + Memi[plist + npars - 1] = 0 + call in_puti (in, INLNFPARAMS, in_geti (in, INLNFPARAMS) - 1) + } + isfit = false + } + + # Print setting. + call printf ("(%s) changed to %s parameter, with value=%g\n") + call pargstr (Memc[pname]) + if (isfit) + call pargstr ("fitting") + else + call pargstr ("constant") + call parg$t ($tval) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingcolond.x b/pkg/xtools/inlfit/ingcolond.x new file mode 100644 index 00000000..453895e3 --- /dev/null +++ b/pkg/xtools/inlfit/ingcolond.x @@ -0,0 +1,362 @@ +include <gset.h> +include <error.h> +include <pkg/inlfit.h> + +# List of colon commands. +define CMDS "|show|low_reject|high_reject|nreject|grow|errors|vshow|constant|\ +fit|tolerance|maxiter|variables|data|page|results|" + +define SHOW 1 # Show fit information +define LOW_REJECT 2 # Set or show lower rejection factor +define HIGH_REJECT 3 # Set or show upper rejection factor +define NREJECT 4 # Set or show rejection iterations +define GROW 5 # Set or show rejection growing radius +define ERRORS 6 # Show fit errors +define VSHOW 7 # Show verbose information +define CONSTANT 8 # Set constant parameter +define FIT 9 # Set fitting parameter +define TOL 10 # Set or show fitting tolerance +define MAXITER 11 # Set or show max number of iterations +define VARIABLES 12 # List the variables +define DATA 13 # List of data +define PAGE 14 # Page through a file +define RESULTS 15 # List the results of the fit + + +# ING_COLON -- Processes colon commands. The common flags and newgraph +# signal changes in fitting parameters or the need to redraw the graph. + +procedure ing_colond (in, cmdstr, gp, gt, nl, x, y, wts, names, npts, nvars, + len_name, newgraph) + +pointer in # INLFIT pointer +char cmdstr[ARB] # Command string +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer for error listing +double x[ARB] # Independent variabels (npts * nvars) +double y[npts] # dependent variables +double wts[npts] # Weights +char names[ARB] # Object names +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of object name +int newgraph # New graph ? + +int ncmd, ival +double fval +pointer sp, cmd + +int nscan(), strdic() +int in_geti() +double in_getd() + +begin + # Allocate string space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Use formated scan to parse the command string. + # The first word is the command and it may be minimum match + # abbreviated with the list of commands. + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, CMDS) + + # Branch on command code. + switch (ncmd) { + case SHOW: # :show - Show the values of the fitting parameters. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_showd (in, "STDOUT") + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_showd (in, Memc[cmd]) + } then + call erract (EA_WARN) + } + + case LOW_REJECT: # :low_reject - List or set lower rejection factor. + call gargd (fval) + if (nscan() == 1) { + call printf ("low_reject = %g\n") + call pargd (in_getd (in, INLLOW)) + } else + call in_putd (in, INLLOW, fval) + + case HIGH_REJECT: # :high_reject - List or set high rejection factor. + call gargd (fval) + if (nscan() == 1) { + call printf ("high_reject = %g\n") + call pargd (in_getd (in, INLHIGH)) + } else + call in_putd (in, INLHIGH, fval) + + case NREJECT: # :nreject - List or set the rejection iterations. + call gargi (ival) + if (nscan() == 1) { + call printf ("nreject = %d\n") + call pargi (in_geti (in, INLNREJECT)) + } else + call in_puti (in, INLNREJECT, ival) + + case GROW: # :grow - List or set the rejection growing. + call gargd (fval) + if (nscan() == 1) { + call printf ("grow = %g\n") + call pargd (in_getd (in, INLGROW)) + } else + call in_putd (in, INLGROW, fval) + + case ERRORS: # :errors - print errors analysis of fit + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_showd (in, "STDOUT") + call ing_errorsd (in, "STDOUT", nl, x, y, wts, npts, nvars) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_showd (in, Memc[cmd]) + call ing_errorsd (in, Memc[cmd], nl, x, y, wts, npts, + nvars) + } then + call erract (EA_WARN) + } + + case VSHOW: # Verbose list of the fitting parameters and results. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_vshowd (in, "STDOUT", nl, x, y, wts, names, npts, + nvars, len_name, gt) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_vshowd (in, Memc[cmd], nl, x, y, wts, names, + npts, nvars, len_name, gt) + } then + call erract (EA_WARN) + } + + case CONSTANT: # Set constant parameter. + call ing_changed (in, CONSTANT) + + case FIT: # Set fitting parameter. + call ing_changed (in, FIT) + + case TOL: # Set or show tolerance. + call gargd (fval) + if (nscan() == 1) { + call printf ("tol = %g\n") + call pargd (in_getd (in, INLTOLERANCE)) + } else + call in_putd (in, INLTOLERANCE, fval) + + case MAXITER: # Set or show max number of iterations. + call gargi (ival) + if (nscan() == 1) { + call printf ("maxiter = %d\n") + call pargi (in_geti (in, INLMAXITER)) + } else + call in_puti (in, INLMAXITER, ival) + + case VARIABLES: # Show the list of variables. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_variablesd (in, "STDOUT", nvars) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_variablesd (in, Memc[cmd], nvars) + } then + call erract (EA_WARN) + } + + case DATA: # List the raw data. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_datad (in, "STDOUT", x, names, npts, nvars, len_name) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_datad (in, Memc[cmd], x, names, npts, nvars, + len_name) + } then + call erract (EA_WARN) + } + + case PAGE: # Page through a file. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) + call printf ("File to be paged is undefined\n") + else + call gpagefile (gp, Memc[cmd], "") + + case RESULTS: # List the results of the fit. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_resultsd (in, "STDOUT", nl, x, y, wts, names, npts, + nvars, len_name) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_resultsd (in, Memc[cmd], nl, x, y, wts, names, + npts, nvars, len_name) + } then + call erract (EA_WARN) + } + + default: # User definable action. + call ing_ucolond (in, gp, gt, nl, x, y, wts, npts, nvars, newgraph) + } + + # Free memory + call sfree (sp) +end + + +# ING_CHANGE -- Change fitting parameter into constant parameter, and +# viceversa. Parameters can be specified either by a name, supplied in +# the parameter labels, or just by a sequence number. + +procedure ing_changed (in, type) + +pointer in # INLFIT descriptor +int type # parameter type (fit, constant) + +bool isfit +int ip, pos, number, npars +double dval +pointer param, value, pname +pointer pvalues, plist, plabels +pointer sp + +bool streq() +int ctoi(), ctod() +int strdic() +int in_geti() +pointer in_getp() + +begin + # Allocate string space. + call smark (sp) + call salloc (param, SZ_LINE, TY_CHAR) + call salloc (value, SZ_LINE, TY_CHAR) + call salloc (pname, SZ_LINE, TY_CHAR) + call salloc (plabels, SZ_LINE, TY_CHAR) + + # Get parameter name. + Memc[param] = EOS + call gargwrd (Memc[param], SZ_LINE) + if (streq (Memc[param], "")) { + call eprintf ("Parameter not specified\n") + call sfree (sp) + return + } + + # Try to find the parameter name in the parameter labels. + call in_gstr (in, INLPLABELS, Memc[plabels], SZ_LINE) + number = strdic (Memc[param], Memc[pname], SZ_LINE, Memc[plabels]) + + # Try to find the parameter by number if it was not found + # by name in the dictionary. + if (number == 0) { + ip = 1 + if (ctoi (Memc[param], ip, number) == 0) { + call eprintf ("Parameter not found (%s)\n") + call pargstr (Memc[param]) + call sfree (sp) + return + } + } + + # Test parameter number. + npars = in_geti (in, INLNPARAMS) + if (number < 1 || number > npars) { + call eprintf ("Parameter out of range (%d)\n") + call pargi (number) + call sfree (sp) + return + } + + # Get pointers to parameter values and list. + pvalues = in_getp (in, INLPARAM) + plist = in_getp (in, INLPLIST) + + # Get new value if specified. Otherwise assume + # old parameter value. + Memc[value] = EOS + call gargwrd (Memc[value], SZ_LINE) + if (streq (Memc[value], "")) + dval = Memd[pvalues + number - 1] + else { + ip = 1 + if (ctod (Memc[value], ip, dval) == 0) { + call eprintf ("Bad parameter value (%s)\n") + call pargstr (Memc[value]) + call sfree (sp) + return + } + } + + # Update parameter value. + Memd[pvalues + number - 1] = dval + + # Find the parameter position in the parameter list. + do pos = 1, npars { + if (Memi[plist + pos - 1] >= number || + Memi[plist + pos - 1] == 0) + break + } + + # Insert or remove parameter from the parameter list + # according with its type, i.e., with the type of change. + # The list is not changed if it's not necesary to do so. + + if (type == FIT) { + if (Memi[plist + pos - 1] != number) { + do ip = npars, pos + 1, -1 + Memi[plist + ip - 1] = Memi[plist + ip - 2] + Memi[plist + pos - 1] = number + call in_puti (in, INLNFPARAMS, in_geti (in, INLNFPARAMS) + 1) + } + isfit = true + } else { + if (Memi[plist + pos - 1] == number) { + do ip = pos, npars - 1 + Memi[plist + ip - 1] = Memi[plist + ip] + Memi[plist + npars - 1] = 0 + call in_puti (in, INLNFPARAMS, in_geti (in, INLNFPARAMS) - 1) + } + isfit = false + } + + # Print setting. + call printf ("(%s) changed to %s parameter, with value=%g\n") + call pargstr (Memc[pname]) + if (isfit) + call pargstr ("fitting") + else + call pargstr ("constant") + call pargd (dval) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingcolonr.x b/pkg/xtools/inlfit/ingcolonr.x new file mode 100644 index 00000000..b9179fc6 --- /dev/null +++ b/pkg/xtools/inlfit/ingcolonr.x @@ -0,0 +1,362 @@ +include <gset.h> +include <error.h> +include <pkg/inlfit.h> + +# List of colon commands. +define CMDS "|show|low_reject|high_reject|nreject|grow|errors|vshow|constant|\ +fit|tolerance|maxiter|variables|data|page|results|" + +define SHOW 1 # Show fit information +define LOW_REJECT 2 # Set or show lower rejection factor +define HIGH_REJECT 3 # Set or show upper rejection factor +define NREJECT 4 # Set or show rejection iterations +define GROW 5 # Set or show rejection growing radius +define ERRORS 6 # Show fit errors +define VSHOW 7 # Show verbose information +define CONSTANT 8 # Set constant parameter +define FIT 9 # Set fitting parameter +define TOL 10 # Set or show fitting tolerance +define MAXITER 11 # Set or show max number of iterations +define VARIABLES 12 # List the variables +define DATA 13 # List of data +define PAGE 14 # Page through a file +define RESULTS 15 # List the results of the fit + + +# ING_COLON -- Processes colon commands. The common flags and newgraph +# signal changes in fitting parameters or the need to redraw the graph. + +procedure ing_colonr (in, cmdstr, gp, gt, nl, x, y, wts, names, npts, nvars, + len_name, newgraph) + +pointer in # INLFIT pointer +char cmdstr[ARB] # Command string +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer for error listing +real x[ARB] # Independent variabels (npts * nvars) +real y[npts] # dependent variables +real wts[npts] # Weights +char names[ARB] # Object names +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of object name +int newgraph # New graph ? + +int ncmd, ival +real fval +pointer sp, cmd + +int nscan(), strdic() +int in_geti() +real in_getr() + +begin + # Allocate string space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Use formated scan to parse the command string. + # The first word is the command and it may be minimum match + # abbreviated with the list of commands. + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, CMDS) + + # Branch on command code. + switch (ncmd) { + case SHOW: # :show - Show the values of the fitting parameters. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_showr (in, "STDOUT") + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_showr (in, Memc[cmd]) + } then + call erract (EA_WARN) + } + + case LOW_REJECT: # :low_reject - List or set lower rejection factor. + call gargr (fval) + if (nscan() == 1) { + call printf ("low_reject = %g\n") + call pargr (in_getr (in, INLLOW)) + } else + call in_putr (in, INLLOW, fval) + + case HIGH_REJECT: # :high_reject - List or set high rejection factor. + call gargr (fval) + if (nscan() == 1) { + call printf ("high_reject = %g\n") + call pargr (in_getr (in, INLHIGH)) + } else + call in_putr (in, INLHIGH, fval) + + case NREJECT: # :nreject - List or set the rejection iterations. + call gargi (ival) + if (nscan() == 1) { + call printf ("nreject = %d\n") + call pargi (in_geti (in, INLNREJECT)) + } else + call in_puti (in, INLNREJECT, ival) + + case GROW: # :grow - List or set the rejection growing. + call gargr (fval) + if (nscan() == 1) { + call printf ("grow = %g\n") + call pargr (in_getr (in, INLGROW)) + } else + call in_putr (in, INLGROW, fval) + + case ERRORS: # :errors - print errors analysis of fit + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_showr (in, "STDOUT") + call ing_errorsr (in, "STDOUT", nl, x, y, wts, npts, nvars) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_showr (in, Memc[cmd]) + call ing_errorsr (in, Memc[cmd], nl, x, y, wts, npts, + nvars) + } then + call erract (EA_WARN) + } + + case VSHOW: # Verbose list of the fitting parameters and results. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_vshowr (in, "STDOUT", nl, x, y, wts, names, npts, + nvars, len_name, gt) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_vshowr (in, Memc[cmd], nl, x, y, wts, names, + npts, nvars, len_name, gt) + } then + call erract (EA_WARN) + } + + case CONSTANT: # Set constant parameter. + call ing_changer (in, CONSTANT) + + case FIT: # Set fitting parameter. + call ing_changer (in, FIT) + + case TOL: # Set or show tolerance. + call gargr (fval) + if (nscan() == 1) { + call printf ("tol = %g\n") + call pargr (in_getr (in, INLTOLERANCE)) + } else + call in_putr (in, INLTOLERANCE, fval) + + case MAXITER: # Set or show max number of iterations. + call gargi (ival) + if (nscan() == 1) { + call printf ("maxiter = %d\n") + call pargi (in_geti (in, INLMAXITER)) + } else + call in_puti (in, INLMAXITER, ival) + + case VARIABLES: # Show the list of variables. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_variablesr (in, "STDOUT", nvars) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_variablesr (in, Memc[cmd], nvars) + } then + call erract (EA_WARN) + } + + case DATA: # List the raw data. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_datar (in, "STDOUT", x, names, npts, nvars, len_name) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_datar (in, Memc[cmd], x, names, npts, nvars, + len_name) + } then + call erract (EA_WARN) + } + + case PAGE: # Page through a file. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) + call printf ("File to be paged is undefined\n") + else + call gpagefile (gp, Memc[cmd], "") + + case RESULTS: # List the results of the fit. + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call gdeactivate (gp, AW_CLEAR) + call ing_title (in, "STDOUT", gt) + call ing_resultsr (in, "STDOUT", nl, x, y, wts, names, npts, + nvars, len_name) + call greactivate (gp, AW_PAUSE) + } else { + iferr { + call ing_title (in, Memc[cmd], gt) + call ing_resultsr (in, Memc[cmd], nl, x, y, wts, names, + npts, nvars, len_name) + } then + call erract (EA_WARN) + } + + default: # User definable action. + call ing_ucolonr (in, gp, gt, nl, x, y, wts, npts, nvars, newgraph) + } + + # Free memory + call sfree (sp) +end + + +# ING_CHANGE -- Change fitting parameter into constant parameter, and +# viceversa. Parameters can be specified either by a name, supplied in +# the parameter labels, or just by a sequence number. + +procedure ing_changer (in, type) + +pointer in # INLFIT descriptor +int type # parameter type (fit, constant) + +bool isfit +int ip, pos, number, npars +real rval +pointer param, value, pname +pointer pvalues, plist, plabels +pointer sp + +bool streq() +int ctoi(), ctor() +int strdic() +int in_geti() +pointer in_getp() + +begin + # Allocate string space. + call smark (sp) + call salloc (param, SZ_LINE, TY_CHAR) + call salloc (value, SZ_LINE, TY_CHAR) + call salloc (pname, SZ_LINE, TY_CHAR) + call salloc (plabels, SZ_LINE, TY_CHAR) + + # Get parameter name. + Memc[param] = EOS + call gargwrd (Memc[param], SZ_LINE) + if (streq (Memc[param], "")) { + call eprintf ("Parameter not specified\n") + call sfree (sp) + return + } + + # Try to find the parameter name in the parameter labels. + call in_gstr (in, INLPLABELS, Memc[plabels], SZ_LINE) + number = strdic (Memc[param], Memc[pname], SZ_LINE, Memc[plabels]) + + # Try to find the parameter by number if it was not found + # by name in the dictionary. + if (number == 0) { + ip = 1 + if (ctoi (Memc[param], ip, number) == 0) { + call eprintf ("Parameter not found (%s)\n") + call pargstr (Memc[param]) + call sfree (sp) + return + } + } + + # Test parameter number. + npars = in_geti (in, INLNPARAMS) + if (number < 1 || number > npars) { + call eprintf ("Parameter out of range (%d)\n") + call pargi (number) + call sfree (sp) + return + } + + # Get pointers to parameter values and list. + pvalues = in_getp (in, INLPARAM) + plist = in_getp (in, INLPLIST) + + # Get new value if specified. Otherwise assume + # old parameter value. + Memc[value] = EOS + call gargwrd (Memc[value], SZ_LINE) + if (streq (Memc[value], "")) + rval = Memr[pvalues + number - 1] + else { + ip = 1 + if (ctor (Memc[value], ip, rval) == 0) { + call eprintf ("Bad parameter value (%s)\n") + call pargstr (Memc[value]) + call sfree (sp) + return + } + } + + # Update parameter value. + Memr[pvalues + number - 1] = rval + + # Find the parameter position in the parameter list. + do pos = 1, npars { + if (Memi[plist + pos - 1] >= number || + Memi[plist + pos - 1] == 0) + break + } + + # Insert or remove parameter from the parameter list + # according with its type, i.e., with the type of change. + # The list is not changed if it's not necesary to do so. + + if (type == FIT) { + if (Memi[plist + pos - 1] != number) { + do ip = npars, pos + 1, -1 + Memi[plist + ip - 1] = Memi[plist + ip - 2] + Memi[plist + pos - 1] = number + call in_puti (in, INLNFPARAMS, in_geti (in, INLNFPARAMS) + 1) + } + isfit = true + } else { + if (Memi[plist + pos - 1] == number) { + do ip = pos, npars - 1 + Memi[plist + ip - 1] = Memi[plist + ip] + Memi[plist + npars - 1] = 0 + call in_puti (in, INLNFPARAMS, in_geti (in, INLNFPARAMS) - 1) + } + isfit = false + } + + # Print setting. + call printf ("(%s) changed to %s parameter, with value=%g\n") + call pargstr (Memc[pname]) + if (isfit) + call pargstr ("fitting") + else + call pargstr ("constant") + call pargr (rval) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingdata.gx b/pkg/xtools/inlfit/ingdata.gx new file mode 100644 index 00000000..80637be1 --- /dev/null +++ b/pkg/xtools/inlfit/ingdata.gx @@ -0,0 +1,86 @@ +include <pkg/inlfit.h> + +define NPERLINE 5 + +# ING_DATA -- List the raw data on the screen. + +procedure ing_data$t (in, file, x, names, npts, nvars, len_name) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +PIXEL x[ARB] # Ordinates (npts * nvars) +char names[ARB] # Object names +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of the name + +int i, j, fd +pointer sp, vnames, name +int open() +int inlstrwrd() +errchk open() + +begin + # Open the output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Test the number of data points. + if (npts == 0) { + call eprintf ("Incomplete output - no data points for fit\n") + return + } + + # Allocate memory. + call smark (sp) + call salloc (vnames, SZ_LINE, TY_CHAR) + call salloc (name, SZ_LINE, TY_CHAR) + + # Get the variable names. + call in_gstr (in, INLVLABELS, Memc[vnames], SZ_LINE) + + # Print title. + do j = 1, nvars + 1 { + if (mod (j, NPERLINE) == 1) { + call fprintf (fd, "\n") + call fprintf (fd, "#") + } + if (j == 1) { + call fprintf (fd, "%14.14s ") + call pargstr ("objectid") + } else if (inlstrwrd (j-1, Memc[name], SZ_LINE, Memc[vnames]) != + 0) { + call fprintf (fd, "%14.14s ") + call pargstr (Memc[name]) + } else { + call fprintf (fd, "%12.12s%02.2d ") + call pargstr ("var") + call pargi (j-1) + } + } + call fprintf (fd, "\n") + + # List the variables values. + do i = 1, npts { + do j = 1, nvars + 1 { + if (j == 1) { + call fprintf (fd, "\n") + call fprintf (fd, "%15.15s") + call pargstr (names[(i-1)*len_name+1]) + } else if (mod (j, NPERLINE) == 1) { + call fprintf (fd, "\n") + call fprintf (fd, "*%14.7g") + call parg$t (x[(i-1)*nvars+j-1]) + } else { + call fprintf (fd, " %14.7g") + call parg$t (x[(i-1)*nvars+j-1]) + } + } + } + call fprintf (fd, "\n\n") + + # Free allocated memory and close output file. + call sfree (sp) + call close (fd) +end diff --git a/pkg/xtools/inlfit/ingdatad.x b/pkg/xtools/inlfit/ingdatad.x new file mode 100644 index 00000000..c1a82797 --- /dev/null +++ b/pkg/xtools/inlfit/ingdatad.x @@ -0,0 +1,86 @@ +include <pkg/inlfit.h> + +define NPERLINE 5 + +# ING_DATA -- List the raw data on the screen. + +procedure ing_datad (in, file, x, names, npts, nvars, len_name) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +double x[ARB] # Ordinates (npts * nvars) +char names[ARB] # Object names +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of the name + +int i, j, fd +pointer sp, vnames, name +int open() +int inlstrwrd() +errchk open() + +begin + # Open the output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Test the number of data points. + if (npts == 0) { + call eprintf ("Incomplete output - no data points for fit\n") + return + } + + # Allocate memory. + call smark (sp) + call salloc (vnames, SZ_LINE, TY_CHAR) + call salloc (name, SZ_LINE, TY_CHAR) + + # Get the variable names. + call in_gstr (in, INLVLABELS, Memc[vnames], SZ_LINE) + + # Print title. + do j = 1, nvars + 1 { + if (mod (j, NPERLINE) == 1) { + call fprintf (fd, "\n") + call fprintf (fd, "#") + } + if (j == 1) { + call fprintf (fd, "%14.14s ") + call pargstr ("objectid") + } else if (inlstrwrd (j-1, Memc[name], SZ_LINE, Memc[vnames]) != + 0) { + call fprintf (fd, "%14.14s ") + call pargstr (Memc[name]) + } else { + call fprintf (fd, "%12.12s%02.2d ") + call pargstr ("var") + call pargi (j-1) + } + } + call fprintf (fd, "\n") + + # List the variables values. + do i = 1, npts { + do j = 1, nvars + 1 { + if (j == 1) { + call fprintf (fd, "\n") + call fprintf (fd, "%15.15s") + call pargstr (names[(i-1)*len_name+1]) + } else if (mod (j, NPERLINE) == 1) { + call fprintf (fd, "\n") + call fprintf (fd, "*%14.7g") + call pargd (x[(i-1)*nvars+j-1]) + } else { + call fprintf (fd, " %14.7g") + call pargd (x[(i-1)*nvars+j-1]) + } + } + } + call fprintf (fd, "\n\n") + + # Free allocated memory and close output file. + call sfree (sp) + call close (fd) +end diff --git a/pkg/xtools/inlfit/ingdatar.x b/pkg/xtools/inlfit/ingdatar.x new file mode 100644 index 00000000..21674540 --- /dev/null +++ b/pkg/xtools/inlfit/ingdatar.x @@ -0,0 +1,86 @@ +include <pkg/inlfit.h> + +define NPERLINE 5 + +# ING_DATA -- List the raw data on the screen. + +procedure ing_datar (in, file, x, names, npts, nvars, len_name) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +real x[ARB] # Ordinates (npts * nvars) +char names[ARB] # Object names +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of the name + +int i, j, fd +pointer sp, vnames, name +int open() +int inlstrwrd() +errchk open() + +begin + # Open the output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Test the number of data points. + if (npts == 0) { + call eprintf ("Incomplete output - no data points for fit\n") + return + } + + # Allocate memory. + call smark (sp) + call salloc (vnames, SZ_LINE, TY_CHAR) + call salloc (name, SZ_LINE, TY_CHAR) + + # Get the variable names. + call in_gstr (in, INLVLABELS, Memc[vnames], SZ_LINE) + + # Print title. + do j = 1, nvars + 1 { + if (mod (j, NPERLINE) == 1) { + call fprintf (fd, "\n") + call fprintf (fd, "#") + } + if (j == 1) { + call fprintf (fd, "%14.14s ") + call pargstr ("objectid") + } else if (inlstrwrd (j-1, Memc[name], SZ_LINE, Memc[vnames]) != + 0) { + call fprintf (fd, "%14.14s ") + call pargstr (Memc[name]) + } else { + call fprintf (fd, "%12.12s%02.2d ") + call pargstr ("var") + call pargi (j-1) + } + } + call fprintf (fd, "\n") + + # List the variables values. + do i = 1, npts { + do j = 1, nvars + 1 { + if (j == 1) { + call fprintf (fd, "\n") + call fprintf (fd, "%15.15s") + call pargstr (names[(i-1)*len_name+1]) + } else if (mod (j, NPERLINE) == 1) { + call fprintf (fd, "\n") + call fprintf (fd, "*%14.7g") + call pargr (x[(i-1)*nvars+j-1]) + } else { + call fprintf (fd, " %14.7g") + call pargr (x[(i-1)*nvars+j-1]) + } + } + } + call fprintf (fd, "\n\n") + + # Free allocated memory and close output file. + call sfree (sp) + call close (fd) +end diff --git a/pkg/xtools/inlfit/ingdefkey.x b/pkg/xtools/inlfit/ingdefkey.x new file mode 100644 index 00000000..2154389d --- /dev/null +++ b/pkg/xtools/inlfit/ingdefkey.x @@ -0,0 +1,182 @@ +include "inlfitdef.h" +include <pkg/inlfit.h> + +# Abort label +define abort 9999 + + +# ING_DEFKEY - Define graph keys + +procedure ing_defkey (in, nvars, newgraph) + +pointer in # INLFIT descriptor +int nvars # number of variables +int newgraph # update graph ? + +char ch +int key # graph key +int axis # axis number +int type[2], num[2] # key types and numbers +int n, ip +pointer line, word, vlabels, str, sp + +int scan() +int ctoi() +int strdic(), strlen() +int inlstrext(), inlstrwrd() +int in_geti() + +begin + # Allocate string space. + call smark (sp) + call salloc (line, SZ_LINE + 1, TY_CHAR) + call salloc (word, SZ_LINE + 1, TY_CHAR) + call salloc (vlabels, SZ_LINE + 1, TY_CHAR) + call salloc (str, SZ_LINE + 1, TY_CHAR) + + # Get graph key to define. + call printf ("Graph key to be defined: ") + call flush (STDOUT) + if (scan() == EOF) + goto abort + call gargc (ch) + + # Convert key type into key number. + switch (ch) { + case '\n': + goto abort + case 'h', 'i', 'j', 'k', 'l': + switch (ch) { + case 'h': + key = 1 + case 'i': + key = 2 + case 'j': + key = 3 + case 'k': + key = 4 + case 'l': + key = 5 + } + default: + call eprintf ("Not a graph key, choose: [h, i, j, k, l]\n") + goto abort + } + + # Get variable label pointer. + call in_gstr (in, INLVLABELS, Memc[vlabels], SZ_LINE) + + # Print current settings for the axis types. + call printf ("Set graph axis types (") + do axis = 1, 2 { + call in_gkey (in, key, axis, type[axis], num[axis]) + switch (type[axis]) { + case KEY_FUNCTION: + call printf ("function") + case KEY_FIT: + call printf ("fit") + case KEY_RESIDUALS: + call printf ("residuals") + case KEY_RATIO: + call printf ("ratio") + case KEY_NONLINEAR: + call printf ("nonlinear") + case KEY_UAXIS: + call sprintf (Memc[str], SZ_LINE, "user%d") + call pargi (num[axis]) + call printf (Memc[str]) + case KEY_VARIABLE: + if (inlstrwrd (num[axis], Memc[str], SZ_LINE, + Memc[vlabels]) != 0) + call printf (Memc[str]) + else { + call sprintf (Memc[str], SZ_LINE, "var%d") + call pargi (num[axis]) + call printf (Memc[str]) + } + default: + call error (0, "ing_defkey: Illegal key type") + } + if (axis == 1) + call printf (", ") + } + call printf (") : ") + call flush (STDOUT) + + # Get line from the input stream. + if (scan() == EOF) + goto abort + call gargstr (Memc[line], SZ_LINE) + + # Get new axis types from input line. + ip = 1 + axis = 1 + call sscan (Memc[line]) + while (axis <= 2) { + + # Get word from line. + if (inlstrext (Memc[line], ip, ", ", YES, Memc[word], + SZ_LINE) == 0) { + if (axis == 2) + call eprintf ("Incomplete definition, usage: X,Y\n") + goto abort + } + + # Search for word in the type dictionary. Keywords can + # be abreviated up to three characters to avoid conflicts + # with user variables. + if (strlen (Memc[word]) >= 3) + type[axis] = strdic (Memc[word], Memc[str], SZ_LINE, KEY_TYPES) + else + type[axis] = 0 + + # Check type. + if (type[axis] == 0) { + type[axis] = KEY_VARIABLE + num[axis] = strdic (Memc[word], Memc[str], SZ_LINE, + Memc[vlabels]) + if (num[axis] == 0) { + call eprintf ("Not a defined key type (%s), choose: [%s]\n") + call pargstr (Memc[word]) + call pargstr (Memc[vlabels]) + goto abort + } + } else if (type[axis] == KEY_VARIABLE || type[axis] == + KEY_UAXIS) { + if (inlstrext (Memc[line], ip, ", ", YES, Memc[word], + SZ_LINE) == 0) { + call eprintf ("Incomplete definition, usage: X,Y\n") + goto abort + } + n = 1 + if (ctoi (Memc[word], n, num[axis]) == 0) { + call eprintf ( "Not a valid var/user number (%s)\n") + call pargstr (Memc[word]) + goto abort + } + if (type[axis] == KEY_VARIABLE && num[axis] > nvars) { + call eprintf ( "Variable number does not exist (%s)\n") + call pargstr (Memc[word]) + goto abort + } + } else + num[axis] = INDEFI + + # Count axis + axis = axis + 1 + } + + # Update axis types. + call in_pkey (in, key, 1, type[1], num[1]) + call in_pkey (in, key, 2, type[2], num[2]) + + # Test if screen needs to be refreshed. + if (in_geti (in, INLGKEY) == key) + newgraph = YES + else + newgraph = NO + +abort + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingdelete.gx b/pkg/xtools/inlfit/ingdelete.gx new file mode 100644 index 00000000..c4cac6d7 --- /dev/null +++ b/pkg/xtools/inlfit/ingdelete.gx @@ -0,0 +1,87 @@ +include <gset.h> +include <mach.h> +include <pkg/gtools.h> + +define MSIZE 2.0 # Mark size (real) + + +# ING_DELETE -- Delete data point nearest the cursor. +# The nearest point to the cursor in NDC coordinates is determined. + +procedure ing_delete$t (in, gp, gt, nl, x, y, wts, npts, nvars, wx, wy) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +PIXEL x[ARB] # Independent variables (npts * nvars) +PIXEL y[npts] # Dependent variables +PIXEL wts[npts] # Weight array +int npts # Number of points +int nvars # Number of variables +real wx, wy # Position to be nearest + +int gt_geti() +pointer sp, xout, yout + +begin + # Allocate memory for axes data + call smark (sp) + call salloc (xout, npts, TY_PIXEL) + call salloc (yout, npts, TY_PIXEL) + + # Get axes data + call ing_axes$t (in, gt, nl, 1, x, y, Mem$t[xout], npts, nvars) + call ing_axes$t (in, gt, nl, 2, x, y, Mem$t[yout], npts, nvars) + + # Transpose axes if necessary + if (gt_geti (gt, GTTRANSPOSE) == NO) + call ing_d1$t (in, gp, Mem$t[xout], Mem$t[yout], wts, npts, wx, wy) + else + call ing_d1$t (in, gp, Mem$t[yout], Mem$t[xout], wts, npts, wy, wx) + + # Free memory + call sfree (sp) +end + + +# ING_D1 -- Do the actual delete. Mark deleted point with zero weigth. + +procedure ing_d1$t (in, gp, x, y, wts, npts, wx, wy) + +pointer in # ICFIT pointer +pointer gp # GIO pointer +PIXEL x[npts], y[npts] # Data points +PIXEL wts[npts] # Weight array +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with non-zero weight. + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] == PIXEL (0.0)) + next + + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark the deleted point with a cross and set the weight to zero. + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + wts[j] = PIXEL (0.0) + } +end diff --git a/pkg/xtools/inlfit/ingdeleted.x b/pkg/xtools/inlfit/ingdeleted.x new file mode 100644 index 00000000..47f66b06 --- /dev/null +++ b/pkg/xtools/inlfit/ingdeleted.x @@ -0,0 +1,87 @@ +include <gset.h> +include <mach.h> +include <pkg/gtools.h> + +define MSIZE 2.0 # Mark size (real) + + +# ING_DELETE -- Delete data point nearest the cursor. +# The nearest point to the cursor in NDC coordinates is determined. + +procedure ing_deleted (in, gp, gt, nl, x, y, wts, npts, nvars, wx, wy) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +double x[ARB] # Independent variables (npts * nvars) +double y[npts] # Dependent variables +double wts[npts] # Weight array +int npts # Number of points +int nvars # Number of variables +real wx, wy # Position to be nearest + +int gt_geti() +pointer sp, xout, yout + +begin + # Allocate memory for axes data + call smark (sp) + call salloc (xout, npts, TY_DOUBLE) + call salloc (yout, npts, TY_DOUBLE) + + # Get axes data + call ing_axesd (in, gt, nl, 1, x, y, Memd[xout], npts, nvars) + call ing_axesd (in, gt, nl, 2, x, y, Memd[yout], npts, nvars) + + # Transpose axes if necessary + if (gt_geti (gt, GTTRANSPOSE) == NO) + call ing_d1d (in, gp, Memd[xout], Memd[yout], wts, npts, wx, wy) + else + call ing_d1d (in, gp, Memd[yout], Memd[xout], wts, npts, wy, wx) + + # Free memory + call sfree (sp) +end + + +# ING_D1 -- Do the actual delete. Mark deleted point with zero weigth. + +procedure ing_d1d (in, gp, x, y, wts, npts, wx, wy) + +pointer in # ICFIT pointer +pointer gp # GIO pointer +double x[npts], y[npts] # Data points +double wts[npts] # Weight array +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with non-zero weight. + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] == double (0.0)) + next + + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark the deleted point with a cross and set the weight to zero. + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + wts[j] = double (0.0) + } +end diff --git a/pkg/xtools/inlfit/ingdeleter.x b/pkg/xtools/inlfit/ingdeleter.x new file mode 100644 index 00000000..27fbd16c --- /dev/null +++ b/pkg/xtools/inlfit/ingdeleter.x @@ -0,0 +1,87 @@ +include <gset.h> +include <mach.h> +include <pkg/gtools.h> + +define MSIZE 2.0 # Mark size (real) + + +# ING_DELETE -- Delete data point nearest the cursor. +# The nearest point to the cursor in NDC coordinates is determined. + +procedure ing_deleter (in, gp, gt, nl, x, y, wts, npts, nvars, wx, wy) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +real x[ARB] # Independent variables (npts * nvars) +real y[npts] # Dependent variables +real wts[npts] # Weight array +int npts # Number of points +int nvars # Number of variables +real wx, wy # Position to be nearest + +int gt_geti() +pointer sp, xout, yout + +begin + # Allocate memory for axes data + call smark (sp) + call salloc (xout, npts, TY_REAL) + call salloc (yout, npts, TY_REAL) + + # Get axes data + call ing_axesr (in, gt, nl, 1, x, y, Memr[xout], npts, nvars) + call ing_axesr (in, gt, nl, 2, x, y, Memr[yout], npts, nvars) + + # Transpose axes if necessary + if (gt_geti (gt, GTTRANSPOSE) == NO) + call ing_d1r (in, gp, Memr[xout], Memr[yout], wts, npts, wx, wy) + else + call ing_d1r (in, gp, Memr[yout], Memr[xout], wts, npts, wy, wx) + + # Free memory + call sfree (sp) +end + + +# ING_D1 -- Do the actual delete. Mark deleted point with zero weigth. + +procedure ing_d1r (in, gp, x, y, wts, npts, wx, wy) + +pointer in # ICFIT pointer +pointer gp # GIO pointer +real x[npts], y[npts] # Data points +real wts[npts] # Weight array +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with non-zero weight. + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] == real (0.0)) + next + + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark the deleted point with a cross and set the weight to zero. + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + wts[j] = real (0.0) + } +end diff --git a/pkg/xtools/inlfit/ingerrors.gx b/pkg/xtools/inlfit/ingerrors.gx new file mode 100644 index 00000000..1125a39a --- /dev/null +++ b/pkg/xtools/inlfit/ingerrors.gx @@ -0,0 +1,139 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# ING_ERRORS -- Compute error diagnostic information and print it on the +# screen. + +procedure ing_errors$t (in, file, nl, x, y, wts, npts, nvars) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +pointer nl # NLFIT pointer +PIXEL x[ARB] # Ordinates (npts * nvars) +PIXEL y[ARB] # Abscissas +PIXEL wts[ARB] # Weights +int npts # Number of data points +int nvars # Number of variables + +bool isfit +int i, j, deleted, rejected, nparams, fd +PIXEL chisqr, variance, rms +pointer sp, fit, wts1, params, errors, rejpts, plist +pointer name, pvnames, labels + +int open(), nlstati(), inlstrwrd(), in_geti() +pointer in_getp() +PIXEL in_rms$t(), nlstat$t() +errchk open() + +begin + # Open the output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Determine the number of coefficients. + nparams = nlstati (nl, NLNPARAMS) + + # Allocate memory for parameters, errors, and parameter list. + call smark (sp) + call salloc (params, nparams, TY_PIXEL) + call salloc (errors, nparams, TY_PIXEL) + call salloc (labels, SZ_LINE + 1, TY_CHAR) + + # Allocate memory for the fit and strings. + call salloc (fit, npts, TY_PIXEL) + call salloc (wts1, npts, TY_PIXEL) + call salloc (name, SZ_LINE + 1, TY_CHAR) + call salloc (pvnames, SZ_LINE + 1, TY_CHAR) + + # Get number of rejected points and rejected point list. + rejected = in_geti (in, INLNREJPTS) + rejpts = in_getp (in, INLREJPTS) + + # Count deleted points. + deleted = 0 + do i = 1, npts { + if (wts[i] == PIXEL (0.0)) + deleted = deleted + 1 + } + + # Assign a zero weight to rejected points. + call amov$t (wts, Mem$t[wts1], npts) + if (rejected > 0) { + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Mem$t[wts1+i-1] = PIXEL (0.0) + } + } + + # Get the parameter values and errors. + call nlvector$t (nl, x, Mem$t[fit], npts, nvars) + call nlpget$t (nl, Mem$t[params], nparams) + call nlerrors$t (nl, y, Mem$t[fit], Mem$t[wts1], npts, variance, + chisqr, Mem$t[errors]) + + # Compute the RMS. + rms = in_rms$t (y, Mem$t[fit], Mem$t[wts1], npts) + + # Print the error analysis. + call fprintf (fd, "\nniterations %d\n") + call pargi (nlstati (nl, NLITER)) + call fprintf (fd, "total_points %d\n") + call pargi (npts) + call fprintf (fd, "rejected %d\n") + call pargi (in_geti (in, INLNREJPTS)) + call fprintf (fd, "deleted %d\n") + call pargi (deleted) + call fprintf (fd, "standard deviation %10.7g\n") + call parg$t (sqrt (variance)) + call fprintf (fd, "reduced chi %10.7g\n") + call parg$t (sqrt (chisqr)) + call fprintf (fd, "average error %10.7g\n") + if (chisqr <= 0) + call parg$t (PIXEL(0.0)) + else + call parg$t (sqrt (max (variance, PIXEL (0.0)) / chisqr)) + call fprintf (fd, "average scatter %10.7g\n") + call parg$t (sqrt (nlstat$t (nl, NLSCATTER))) + call fprintf (fd, "RMS %10.7g\n") + call parg$t (rms) + + # Print parameter values and errors. + call in_gstr (in, INLPLABELS, Memc[labels], SZ_LINE) + call strcpy (Memc[labels], Memc[pvnames], SZ_LINE) + call fprintf (fd, "\n%-10.10s %14.14s %14.14s\n") + call pargstr ("parameter") + call pargstr ("value") + call pargstr ("error") + plist = in_getp (in, INLPLIST) + do i = 1, nparams { + if (inlstrwrd (i, Memc[name], SZ_LINE, Memc[pvnames]) != 0) { + call fprintf (fd, "%-10.10s ") + call pargstr (Memc[name]) + } else { + call fprintf (fd, "%-10.2d ") + call pargi (i) + } + call fprintf (fd, "%14.7f %14.7f (%s)\n") + call parg$t (Mem$t[params+i-1]) + call parg$t (Mem$t[errors+i-1]) + isfit = false + do j = 1, nparams { + if (Memi[plist+j-1] == i) { + isfit = true + break + } + } + if (isfit) + call pargstr ("fit") + else + call pargstr ("constant") + } + call fprintf (fd, "\n") + + # Free allocated memory. + call sfree (sp) + call close (fd) +end diff --git a/pkg/xtools/inlfit/ingerrorsd.x b/pkg/xtools/inlfit/ingerrorsd.x new file mode 100644 index 00000000..44302b68 --- /dev/null +++ b/pkg/xtools/inlfit/ingerrorsd.x @@ -0,0 +1,139 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# ING_ERRORS -- Compute error diagnostic information and print it on the +# screen. + +procedure ing_errorsd (in, file, nl, x, y, wts, npts, nvars) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +pointer nl # NLFIT pointer +double x[ARB] # Ordinates (npts * nvars) +double y[ARB] # Abscissas +double wts[ARB] # Weights +int npts # Number of data points +int nvars # Number of variables + +bool isfit +int i, j, deleted, rejected, nparams, fd +double chisqr, variance, rms +pointer sp, fit, wts1, params, errors, rejpts, plist +pointer name, pvnames, labels + +int open(), nlstati(), inlstrwrd(), in_geti() +pointer in_getp() +double in_rmsd(), nlstatd() +errchk open() + +begin + # Open the output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Determine the number of coefficients. + nparams = nlstati (nl, NLNPARAMS) + + # Allocate memory for parameters, errors, and parameter list. + call smark (sp) + call salloc (params, nparams, TY_DOUBLE) + call salloc (errors, nparams, TY_DOUBLE) + call salloc (labels, SZ_LINE + 1, TY_CHAR) + + # Allocate memory for the fit and strings. + call salloc (fit, npts, TY_DOUBLE) + call salloc (wts1, npts, TY_DOUBLE) + call salloc (name, SZ_LINE + 1, TY_CHAR) + call salloc (pvnames, SZ_LINE + 1, TY_CHAR) + + # Get number of rejected points and rejected point list. + rejected = in_geti (in, INLNREJPTS) + rejpts = in_getp (in, INLREJPTS) + + # Count deleted points. + deleted = 0 + do i = 1, npts { + if (wts[i] == double (0.0)) + deleted = deleted + 1 + } + + # Assign a zero weight to rejected points. + call amovd (wts, Memd[wts1], npts) + if (rejected > 0) { + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Memd[wts1+i-1] = double (0.0) + } + } + + # Get the parameter values and errors. + call nlvectord (nl, x, Memd[fit], npts, nvars) + call nlpgetd (nl, Memd[params], nparams) + call nlerrorsd (nl, y, Memd[fit], Memd[wts1], npts, variance, + chisqr, Memd[errors]) + + # Compute the RMS. + rms = in_rmsd (y, Memd[fit], Memd[wts1], npts) + + # Print the error analysis. + call fprintf (fd, "\nniterations %d\n") + call pargi (nlstati (nl, NLITER)) + call fprintf (fd, "total_points %d\n") + call pargi (npts) + call fprintf (fd, "rejected %d\n") + call pargi (in_geti (in, INLNREJPTS)) + call fprintf (fd, "deleted %d\n") + call pargi (deleted) + call fprintf (fd, "standard deviation %10.7g\n") + call pargd (sqrt (variance)) + call fprintf (fd, "reduced chi %10.7g\n") + call pargd (sqrt (chisqr)) + call fprintf (fd, "average error %10.7g\n") + if (chisqr <= 0) + call pargd (double(0.0)) + else + call pargd (sqrt (max (variance, double (0.0)) / chisqr)) + call fprintf (fd, "average scatter %10.7g\n") + call pargd (sqrt (nlstatd (nl, NLSCATTER))) + call fprintf (fd, "RMS %10.7g\n") + call pargd (rms) + + # Print parameter values and errors. + call in_gstr (in, INLPLABELS, Memc[labels], SZ_LINE) + call strcpy (Memc[labels], Memc[pvnames], SZ_LINE) + call fprintf (fd, "\n%-10.10s %14.14s %14.14s\n") + call pargstr ("parameter") + call pargstr ("value") + call pargstr ("error") + plist = in_getp (in, INLPLIST) + do i = 1, nparams { + if (inlstrwrd (i, Memc[name], SZ_LINE, Memc[pvnames]) != 0) { + call fprintf (fd, "%-10.10s ") + call pargstr (Memc[name]) + } else { + call fprintf (fd, "%-10.2d ") + call pargi (i) + } + call fprintf (fd, "%14.7f %14.7f (%s)\n") + call pargd (Memd[params+i-1]) + call pargd (Memd[errors+i-1]) + isfit = false + do j = 1, nparams { + if (Memi[plist+j-1] == i) { + isfit = true + break + } + } + if (isfit) + call pargstr ("fit") + else + call pargstr ("constant") + } + call fprintf (fd, "\n") + + # Free allocated memory. + call sfree (sp) + call close (fd) +end diff --git a/pkg/xtools/inlfit/ingerrorsr.x b/pkg/xtools/inlfit/ingerrorsr.x new file mode 100644 index 00000000..7d1b86d4 --- /dev/null +++ b/pkg/xtools/inlfit/ingerrorsr.x @@ -0,0 +1,139 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# ING_ERRORS -- Compute error diagnostic information and print it on the +# screen. + +procedure ing_errorsr (in, file, nl, x, y, wts, npts, nvars) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +pointer nl # NLFIT pointer +real x[ARB] # Ordinates (npts * nvars) +real y[ARB] # Abscissas +real wts[ARB] # Weights +int npts # Number of data points +int nvars # Number of variables + +bool isfit +int i, j, deleted, rejected, nparams, fd +real chisqr, variance, rms +pointer sp, fit, wts1, params, errors, rejpts, plist +pointer name, pvnames, labels + +int open(), nlstati(), inlstrwrd(), in_geti() +pointer in_getp() +real in_rmsr(), nlstatr() +errchk open() + +begin + # Open the output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Determine the number of coefficients. + nparams = nlstati (nl, NLNPARAMS) + + # Allocate memory for parameters, errors, and parameter list. + call smark (sp) + call salloc (params, nparams, TY_REAL) + call salloc (errors, nparams, TY_REAL) + call salloc (labels, SZ_LINE + 1, TY_CHAR) + + # Allocate memory for the fit and strings. + call salloc (fit, npts, TY_REAL) + call salloc (wts1, npts, TY_REAL) + call salloc (name, SZ_LINE + 1, TY_CHAR) + call salloc (pvnames, SZ_LINE + 1, TY_CHAR) + + # Get number of rejected points and rejected point list. + rejected = in_geti (in, INLNREJPTS) + rejpts = in_getp (in, INLREJPTS) + + # Count deleted points. + deleted = 0 + do i = 1, npts { + if (wts[i] == real (0.0)) + deleted = deleted + 1 + } + + # Assign a zero weight to rejected points. + call amovr (wts, Memr[wts1], npts) + if (rejected > 0) { + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Memr[wts1+i-1] = real (0.0) + } + } + + # Get the parameter values and errors. + call nlvectorr (nl, x, Memr[fit], npts, nvars) + call nlpgetr (nl, Memr[params], nparams) + call nlerrorsr (nl, y, Memr[fit], Memr[wts1], npts, variance, + chisqr, Memr[errors]) + + # Compute the RMS. + rms = in_rmsr (y, Memr[fit], Memr[wts1], npts) + + # Print the error analysis. + call fprintf (fd, "\nniterations %d\n") + call pargi (nlstati (nl, NLITER)) + call fprintf (fd, "total_points %d\n") + call pargi (npts) + call fprintf (fd, "rejected %d\n") + call pargi (in_geti (in, INLNREJPTS)) + call fprintf (fd, "deleted %d\n") + call pargi (deleted) + call fprintf (fd, "standard deviation %10.7g\n") + call pargr (sqrt (variance)) + call fprintf (fd, "reduced chi %10.7g\n") + call pargr (sqrt (chisqr)) + call fprintf (fd, "average error %10.7g\n") + if (chisqr <= 0) + call pargr (real(0.0)) + else + call pargr (sqrt (max (variance, real (0.0)) / chisqr)) + call fprintf (fd, "average scatter %10.7g\n") + call pargr (sqrt (nlstatr (nl, NLSCATTER))) + call fprintf (fd, "RMS %10.7g\n") + call pargr (rms) + + # Print parameter values and errors. + call in_gstr (in, INLPLABELS, Memc[labels], SZ_LINE) + call strcpy (Memc[labels], Memc[pvnames], SZ_LINE) + call fprintf (fd, "\n%-10.10s %14.14s %14.14s\n") + call pargstr ("parameter") + call pargstr ("value") + call pargstr ("error") + plist = in_getp (in, INLPLIST) + do i = 1, nparams { + if (inlstrwrd (i, Memc[name], SZ_LINE, Memc[pvnames]) != 0) { + call fprintf (fd, "%-10.10s ") + call pargstr (Memc[name]) + } else { + call fprintf (fd, "%-10.2d ") + call pargi (i) + } + call fprintf (fd, "%14.7f %14.7f (%s)\n") + call pargr (Memr[params+i-1]) + call pargr (Memr[errors+i-1]) + isfit = false + do j = 1, nparams { + if (Memi[plist+j-1] == i) { + isfit = true + break + } + } + if (isfit) + call pargstr ("fit") + else + call pargstr ("constant") + } + call fprintf (fd, "\n") + + # Free allocated memory. + call sfree (sp) + call close (fd) +end diff --git a/pkg/xtools/inlfit/inget.gx b/pkg/xtools/inlfit/inget.gx new file mode 100644 index 00000000..907a0331 --- /dev/null +++ b/pkg/xtools/inlfit/inget.gx @@ -0,0 +1,220 @@ +.help inget + int = in_geti (in, param) + pointer= in_getp (in, param) + real = in_getr (in, param) + double = in_getd (in, param) + in_gstr (in, param, str, maxch) + in_gkey (in, key, axis, type, varnum) +.endhelp + +include <pkg/inlfit.h> +include "inlfitdef.h" + +# IN_GETI -- Get integer valued parameters. + +int procedure in_geti (in, param) + +pointer in # INLFIT pointer +int param # parameter to get + +begin + switch (param) { + case INLFUNCTION: + return (IN_FUNC (in)) + case INLDERIVATIVE: + return (IN_DFUNC (in)) + case INLNPARAMS: + return (IN_NPARAMS (in)) + case INLNFPARAMS: + return (IN_NFPARAMS (in)) + case INLNVARS: + return (IN_NVARS (in)) + case INLNPTS: + return (IN_NPTS (in)) + case INLMAXITER: + return (IN_MAXITER (in)) + case INLNREJECT: + return (IN_NREJECT(in)) + case INLNREJPTS: + return (IN_NREJPTS (in)) + case INLUAXES: + return (IN_UAXES (in)) + case INLUCOLON: + return (IN_UCOLON (in)) + case INLUFIT: + return (IN_UFIT (in)) + case INLOVERPLOT: + return (IN_OVERPLOT (in)) + case INLPLOTFIT: + return (IN_PLOTFIT (in)) + case INLFITERROR: + return (IN_FITERROR (in)) + case INLGKEY: + return (IN_GKEY (in)) + default: + call error (0, "INLFIT, in_geti: Unknown parameter") + } +end + + +$for (rd) +# IN_GET[RD] -- Get real/double valued parameters. + +PIXEL procedure in_get$t (in, param) + +pointer in # INLFIT pointer +int param # parameter to get + +begin + switch (param) { + case INLTOLERANCE: + return (IN_TOL$T (in)) + case INLLOW: + return (IN_LOW$T (in)) + case INLHIGH: + return (IN_HIGH$T (in)) + case INLGROW: + return (IN_GROW$T (in)) + default: + call error (0, "INLFIT, in_get[rd]: Unknown parameter") + } +end +$endfor + + +# IN_GETP -- Get pointer valued parameters. + +pointer procedure in_getp (in, param) + +pointer in # INLFIT pointer +int param # parameter to get + +begin + switch (param) { + case INLPARAM: + return (IN_PARAM (in)) + case INLDPARAM: + return (IN_DPARAM (in)) + case INLPLIST: + return (IN_PLIST (in)) + case INLSFLOAT: + return (IN_SFLOAT (in)) + case INLREJPTS: + return (IN_REJPTS (in)) + case INLXMIN: + return (IN_XMIN (in)) + case INLXMAX: + return (IN_XMAX (in)) + case INLSGAXES: + return (IN_SGAXES (in)) + default: + call error (0, "INLFIT, in_getp: Unknown parameter") + } +end + + +# IN_GETC -- Get character pointer valued parameters. + +pointer procedure in_getc (in, param) + +pointer in # INLFIT pointer +int param # parameter to get + +begin + switch (param) { + case INLLABELS: + return (IN_LABELS (in)) + case INLUNITS: + return (IN_UNITS (in)) + case INLFLABELS: + return (IN_FLABELS (in)) + case INLFUNITS: + return (IN_FUNITS (in)) + case INLPLABELS: + return (IN_PLABELS (in)) + case INLPUNITS: + return (IN_PUNITS (in)) + case INLVLABELS: + return (IN_VLABELS (in)) + case INLVUNITS: + return (IN_VUNITS (in)) + case INLUSERLABELS: + return (IN_USERLABELS (in)) + case INLUSERUNITS: + return (IN_USERUNITS (in)) + case INLHELP: + return (IN_HELP (in)) + case INLPROMPT: + return (IN_PROMPT (in)) + default: + call error (0, "INLFIT, in_getc: Unknown parameter") + } +end + + +# IN_GSTR -- Get string valued parameters. + +procedure in_gstr (in, param, str, maxch) + +pointer in # INLFIT pointer +int param # parameter to get +char str[maxch] # string value +int maxch # maximum number of characters + +begin + switch (param) { + case INLLABELS: + call strcpy (Memc[IN_LABELS (in)], str, maxch) + case INLUNITS: + call strcpy (Memc[IN_UNITS (in)], str, maxch) + case INLFLABELS: + call strcpy (Memc[IN_FLABELS (in)], str, maxch) + case INLFUNITS: + call strcpy (Memc[IN_FUNITS (in)], str, maxch) + case INLPLABELS: + call strcpy (Memc[IN_PLABELS (in)], str, maxch) + case INLPUNITS: + call strcpy (Memc[IN_PUNITS (in)], str, maxch) + case INLVLABELS: + call strcpy (Memc[IN_VLABELS (in)], str, maxch) + case INLVUNITS: + call strcpy (Memc[IN_VUNITS (in)], str, maxch) + case INLUSERLABELS: + call strcpy (Memc[IN_USERLABELS (in)], str, maxch) + case INLUSERUNITS: + call strcpy (Memc[IN_USERUNITS (in)], str, maxch) + case INLHELP: + call strcpy (Memc[IN_HELP (in)], str, maxch) + case INLPROMPT: + call strcpy (Memc[IN_PROMPT (in)], str, maxch) + default: + call error (0, "INLFIT, in_gstr: Unknown parameter") + } +end + + +# IN_GKEY -- Get key parameters. + +procedure in_gkey (in, key, axis, type, varnum) + +pointer in # INLFIT pointer +int key # key to get +int axis # axis number +int type # axis type (output) +int varnum # axis variable number (output) + +begin + # Check ranges + if (key < 1 || key > INLNGKEYS) + call error (0, "INLFIT, in_pkey: Illegal key") + + # Get data + if (axis == INLXAXIS) { + type = IN_GXTYPE (in, key) + varnum = IN_GXNUMBER (in, key) + } else if (axis == INLYAXIS) { + type = IN_GYTYPE (in, key) + varnum = IN_GYNUMBER (in, key) + } else + call error (0, "INLFIT, in_gkey: Illegal axis") +end diff --git a/pkg/xtools/inlfit/inget.x b/pkg/xtools/inlfit/inget.x new file mode 100644 index 00000000..aa31a8cb --- /dev/null +++ b/pkg/xtools/inlfit/inget.x @@ -0,0 +1,242 @@ +.help inget + int = in_geti (in, param) + pointer= in_getp (in, param) + real = in_getr (in, param) + double = in_getd (in, param) + in_gstr (in, param, str, maxch) + in_gkey (in, key, axis, type, varnum) +.endhelp + +include <pkg/inlfit.h> +include "inlfitdef.h" + +# IN_GETI -- Get integer valued parameters. + +int procedure in_geti (in, param) + +pointer in # INLFIT pointer +int param # parameter to get + +begin + switch (param) { + case INLFUNCTION: + return (IN_FUNC (in)) + case INLDERIVATIVE: + return (IN_DFUNC (in)) + case INLNPARAMS: + return (IN_NPARAMS (in)) + case INLNFPARAMS: + return (IN_NFPARAMS (in)) + case INLNVARS: + return (IN_NVARS (in)) + case INLNPTS: + return (IN_NPTS (in)) + case INLMAXITER: + return (IN_MAXITER (in)) + case INLNREJECT: + return (IN_NREJECT(in)) + case INLNREJPTS: + return (IN_NREJPTS (in)) + case INLUAXES: + return (IN_UAXES (in)) + case INLUCOLON: + return (IN_UCOLON (in)) + case INLUFIT: + return (IN_UFIT (in)) + case INLOVERPLOT: + return (IN_OVERPLOT (in)) + case INLPLOTFIT: + return (IN_PLOTFIT (in)) + case INLFITERROR: + return (IN_FITERROR (in)) + case INLGKEY: + return (IN_GKEY (in)) + default: + call error (0, "INLFIT, in_geti: Unknown parameter") + } +end + + + +# IN_GET[RD] -- Get real/double valued parameters. + +real procedure in_getr (in, param) + +pointer in # INLFIT pointer +int param # parameter to get + +begin + switch (param) { + case INLTOLERANCE: + return (IN_TOLR (in)) + case INLLOW: + return (IN_LOWR (in)) + case INLHIGH: + return (IN_HIGHR (in)) + case INLGROW: + return (IN_GROWR (in)) + default: + call error (0, "INLFIT, in_get[rd]: Unknown parameter") + } +end + +# IN_GET[RD] -- Get real/double valued parameters. + +double procedure in_getd (in, param) + +pointer in # INLFIT pointer +int param # parameter to get + +begin + switch (param) { + case INLTOLERANCE: + return (IN_TOLD (in)) + case INLLOW: + return (IN_LOWD (in)) + case INLHIGH: + return (IN_HIGHD (in)) + case INLGROW: + return (IN_GROWD (in)) + default: + call error (0, "INLFIT, in_get[rd]: Unknown parameter") + } +end + + + +# IN_GETP -- Get pointer valued parameters. + +pointer procedure in_getp (in, param) + +pointer in # INLFIT pointer +int param # parameter to get + +begin + switch (param) { + case INLPARAM: + return (IN_PARAM (in)) + case INLDPARAM: + return (IN_DPARAM (in)) + case INLPLIST: + return (IN_PLIST (in)) + case INLSFLOAT: + return (IN_SFLOAT (in)) + case INLREJPTS: + return (IN_REJPTS (in)) + case INLXMIN: + return (IN_XMIN (in)) + case INLXMAX: + return (IN_XMAX (in)) + case INLSGAXES: + return (IN_SGAXES (in)) + default: + call error (0, "INLFIT, in_getp: Unknown parameter") + } +end + + +# IN_GETC -- Get character pointer valued parameters. + +pointer procedure in_getc (in, param) + +pointer in # INLFIT pointer +int param # parameter to get + +begin + switch (param) { + case INLLABELS: + return (IN_LABELS (in)) + case INLUNITS: + return (IN_UNITS (in)) + case INLFLABELS: + return (IN_FLABELS (in)) + case INLFUNITS: + return (IN_FUNITS (in)) + case INLPLABELS: + return (IN_PLABELS (in)) + case INLPUNITS: + return (IN_PUNITS (in)) + case INLVLABELS: + return (IN_VLABELS (in)) + case INLVUNITS: + return (IN_VUNITS (in)) + case INLUSERLABELS: + return (IN_USERLABELS (in)) + case INLUSERUNITS: + return (IN_USERUNITS (in)) + case INLHELP: + return (IN_HELP (in)) + case INLPROMPT: + return (IN_PROMPT (in)) + default: + call error (0, "INLFIT, in_getc: Unknown parameter") + } +end + + +# IN_GSTR -- Get string valued parameters. + +procedure in_gstr (in, param, str, maxch) + +pointer in # INLFIT pointer +int param # parameter to get +char str[maxch] # string value +int maxch # maximum number of characters + +begin + switch (param) { + case INLLABELS: + call strcpy (Memc[IN_LABELS (in)], str, maxch) + case INLUNITS: + call strcpy (Memc[IN_UNITS (in)], str, maxch) + case INLFLABELS: + call strcpy (Memc[IN_FLABELS (in)], str, maxch) + case INLFUNITS: + call strcpy (Memc[IN_FUNITS (in)], str, maxch) + case INLPLABELS: + call strcpy (Memc[IN_PLABELS (in)], str, maxch) + case INLPUNITS: + call strcpy (Memc[IN_PUNITS (in)], str, maxch) + case INLVLABELS: + call strcpy (Memc[IN_VLABELS (in)], str, maxch) + case INLVUNITS: + call strcpy (Memc[IN_VUNITS (in)], str, maxch) + case INLUSERLABELS: + call strcpy (Memc[IN_USERLABELS (in)], str, maxch) + case INLUSERUNITS: + call strcpy (Memc[IN_USERUNITS (in)], str, maxch) + case INLHELP: + call strcpy (Memc[IN_HELP (in)], str, maxch) + case INLPROMPT: + call strcpy (Memc[IN_PROMPT (in)], str, maxch) + default: + call error (0, "INLFIT, in_gstr: Unknown parameter") + } +end + + +# IN_GKEY -- Get key parameters. + +procedure in_gkey (in, key, axis, type, varnum) + +pointer in # INLFIT pointer +int key # key to get +int axis # axis number +int type # axis type (output) +int varnum # axis variable number (output) + +begin + # Check ranges + if (key < 1 || key > INLNGKEYS) + call error (0, "INLFIT, in_pkey: Illegal key") + + # Get data + if (axis == INLXAXIS) { + type = IN_GXTYPE (in, key) + varnum = IN_GXNUMBER (in, key) + } else if (axis == INLYAXIS) { + type = IN_GYTYPE (in, key) + varnum = IN_GYNUMBER (in, key) + } else + call error (0, "INLFIT, in_gkey: Illegal axis") +end diff --git a/pkg/xtools/inlfit/ingfit.gx b/pkg/xtools/inlfit/ingfit.gx new file mode 100644 index 00000000..4dc5b330 --- /dev/null +++ b/pkg/xtools/inlfit/ingfit.gx @@ -0,0 +1,204 @@ +include <error.h> +include <mach.h> +include <pkg/gtools.h> +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# IN_GFIT -- Fit a function using non-linear least squares. The function +# can have an arbitrary number of independent variables. This is the main +# entry point for the interactive part of the INLFIT package. + + +procedure ing_fit$t (in, gp, cursor, gt, nl, x, y, wts, names, npts, nvars, + len_name, wtflag, stat) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +char cursor[ARB] # GIO cursor input +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +PIXEL x[ARB] # independent variables (npts * nvars) +PIXEL y[ARB] # dependent variables +PIXEL wts[ARB] # weigths +char names[ARB] # star ids +int npts # number of points +int nvars # number of variables +int len_name # length of an object name +int wtflag # type of weighting +int stat # Error code (output) + +int i, wcs, key, gkey, newgraph +int xtype, xvar, ytype, yvar, xt, xv, yt, yv +PIXEL fit +pointer sp, cmd, oldwts, help, prompt +real wx, wy + +int gt_gcur1(), ing_nearest$t(), in_geti() +PIXEL nleval$t() + +begin + # Allocate string space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate and initialize a copy of the weights. A new copy + # of the weights is used because it is necessary to have the + # original values to restore them back when the user deletes + # and undeletes points. + + call salloc (oldwts, npts, TY_PIXEL) + call amov$t (wts, Mem$t[oldwts], npts) + + # Allocate space for help page and prompt, and get them. + call salloc (help, SZ_LINE, TY_CHAR) + call salloc (prompt, SZ_LINE, TY_CHAR) + call in_gstr (in, INLHELP, Memc[help], SZ_LINE) + call in_gstr (in, INLPROMPT, Memc[prompt], SZ_LINE) + + # Initialize INLFIT flags. + call in_puti (in, INLOVERPLOT, NO) + + # Initialize loop control variables. The first action + # is to fit the data, in order to have all the fit + # parameters set. + key = 'f' + newgraph = YES + + # Get initial setup for axes. + gkey = in_geti (in, INLGKEY) + call in_gkey (in, gkey, INLXAXIS, xtype, xvar) + call in_gkey (in, gkey, INLYAXIS, xtype, xvar) + + # Loop reading cursor commands. + repeat { + switch (key) { + case '?': # Print help text. + call gpagefile (gp, Memc[help], Memc[prompt]) + + case ':': # List or set parameters. + if (Memc[cmd] == '/') + call gt_colon (Memc[cmd], gp, gt, newgraph) + else + call ing_colon$t (in, Memc[cmd], gp, gt, nl, x, y, wts, + names, npts, nvars, len_name, newgraph) + + case 'c': # Print the positions and useful info on data points. + + i = ing_nearest$t (in, gp, gt, nl, x, y, npts, nvars, wx, wy) + if (i != 0) { + fit = nleval$t (nl, x[(i-1)*nvars+1], nvars) + call printf ( + "%d %s x=%g y=%g func=%g fit=%g, resid=%g\n") + call pargi (i) + call pargstr (names[(i-1)*len_name+1]) + call pargr (wx) + call pargr (wy) + call parg$t (y[i]) + call parg$t (fit) + call parg$t (y[i] - fit) + } + + case 'd': # Delete data points. + call ing_delete$t (in, gp, gt, nl, x, y, wts, npts, nvars, + wx, wy) + + case 'f': # Fit the function. + + # Fit. + do i = 1, npts { + if (wts[i] > PIXEL(0.0)) + wts[i] = Mem$t[oldwts+i-1] + } + call in_fit$t (in, nl, x, y, wts, npts, nvars, wtflag, stat) + + newgraph = YES + + case 'g': # Set graph axistype types. + call ing_defkey (in, nvars, newgraph) + + case 'h': + if (in_geti (in, INLGKEY) != 1) { + call in_puti (in, INLGKEY, 1) + newgraph = YES + } + + case 'i': + if (in_geti (in, INLGKEY) != 2) { + call in_puti (in, INLGKEY, 2) + newgraph = YES + } + + case 'j': + if (in_geti (in, INLGKEY) != 3) { + call in_puti (in, INLGKEY, 3) + newgraph = YES + } + + case 'k': + if (in_geti (in, INLGKEY) != 4) { + call in_puti (in, INLGKEY, 4) + newgraph = YES + } + + case 'l': + if (in_geti (in, INLGKEY) != 5) { + call in_puti (in, INLGKEY, 5) + newgraph = YES + } + + case 'o': # Set the overplot flag. + call in_puti (in, INLOVERPLOT, YES) + + case 'r': # Redraw the graph. + newgraph = YES + + case 't': # Toggle overplot fit flag. + if (in_geti (in, INLPLOTFIT) == YES) + call in_puti (in, INLPLOTFIT, NO) + else + call in_puti (in, INLPLOTFIT, YES) + newgraph = YES + + case 'u': # Undelete data points. + call ing_undelete$t (in, gp, gt, nl, x, y, wts, Mem$t[oldwts], + npts, nvars, wx, wy) + + case 'w': # Window graph. + call gt_window (gt, gp, cursor, newgraph) + + case 'I': # Interrupt. + call fatal (0, "Interrupt") + + default: # Let the user decide on any other keys. + call ing_ufit (in, gp, gt, nl, wx, wy, wcs, key, Memc[cmd]) + } + + # Redraw the graph if necessary. + if (newgraph == YES) { + gkey = in_geti (in, INLGKEY) + call in_gkey (in, gkey, INLXAXIS, xt, xv) + if (xt != xtype || xv != xvar) { + call in_gkey (in, gkey, INLXAXIS, xtype, xvar) + call gt_setr (gt, GTXMIN, INDEFR) + call gt_setr (gt, GTXMAX, INDEFR) + } + call in_gkey (in, gkey, INLYAXIS, yt, yv) + if (xt != xtype || xv != xvar) { + call in_gkey (in, gkey, INLYAXIS, ytype, yvar) + call gt_setr (gt, GTYMIN, INDEFR) + call gt_setr (gt, GTYMAX, INDEFR) + } + call ing_graph$t (in, gp, gt, nl, x, y, wts, npts, nvars) + newgraph = NO + } + + if (cursor[1] == EOS) + break + + } until (gt_gcur1 (gt, cursor, wx, wy, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingfitd.x b/pkg/xtools/inlfit/ingfitd.x new file mode 100644 index 00000000..b31364e0 --- /dev/null +++ b/pkg/xtools/inlfit/ingfitd.x @@ -0,0 +1,204 @@ +include <error.h> +include <mach.h> +include <pkg/gtools.h> +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# IN_GFIT -- Fit a function using non-linear least squares. The function +# can have an arbitrary number of independent variables. This is the main +# entry point for the interactive part of the INLFIT package. + + +procedure ing_fitd (in, gp, cursor, gt, nl, x, y, wts, names, npts, nvars, + len_name, wtflag, stat) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +char cursor[ARB] # GIO cursor input +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +double x[ARB] # independent variables (npts * nvars) +double y[ARB] # dependent variables +double wts[ARB] # weigths +char names[ARB] # star ids +int npts # number of points +int nvars # number of variables +int len_name # length of an object name +int wtflag # type of weighting +int stat # Error code (output) + +int i, wcs, key, gkey, newgraph +int xtype, xvar, ytype, yvar, xt, xv, yt, yv +double fit +pointer sp, cmd, oldwts, help, prompt +real wx, wy + +int gt_gcur1(), ing_nearestd(), in_geti() +double nlevald() + +begin + # Allocate string space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate and initialize a copy of the weights. A new copy + # of the weights is used because it is necessary to have the + # original values to restore them back when the user deletes + # and undeletes points. + + call salloc (oldwts, npts, TY_DOUBLE) + call amovd (wts, Memd[oldwts], npts) + + # Allocate space for help page and prompt, and get them. + call salloc (help, SZ_LINE, TY_CHAR) + call salloc (prompt, SZ_LINE, TY_CHAR) + call in_gstr (in, INLHELP, Memc[help], SZ_LINE) + call in_gstr (in, INLPROMPT, Memc[prompt], SZ_LINE) + + # Initialize INLFIT flags. + call in_puti (in, INLOVERPLOT, NO) + + # Initialize loop control variables. The first action + # is to fit the data, in order to have all the fit + # parameters set. + key = 'f' + newgraph = YES + + # Get initial setup for axes. + gkey = in_geti (in, INLGKEY) + call in_gkey (in, gkey, INLXAXIS, xtype, xvar) + call in_gkey (in, gkey, INLYAXIS, xtype, xvar) + + # Loop reading cursor commands. + repeat { + switch (key) { + case '?': # Print help text. + call gpagefile (gp, Memc[help], Memc[prompt]) + + case ':': # List or set parameters. + if (Memc[cmd] == '/') + call gt_colon (Memc[cmd], gp, gt, newgraph) + else + call ing_colond (in, Memc[cmd], gp, gt, nl, x, y, wts, + names, npts, nvars, len_name, newgraph) + + case 'c': # Print the positions and useful info on data points. + + i = ing_nearestd (in, gp, gt, nl, x, y, npts, nvars, wx, wy) + if (i != 0) { + fit = nlevald (nl, x[(i-1)*nvars+1], nvars) + call printf ( + "%d %s x=%g y=%g func=%g fit=%g, resid=%g\n") + call pargi (i) + call pargstr (names[(i-1)*len_name+1]) + call pargr (wx) + call pargr (wy) + call pargd (y[i]) + call pargd (fit) + call pargd (y[i] - fit) + } + + case 'd': # Delete data points. + call ing_deleted (in, gp, gt, nl, x, y, wts, npts, nvars, + wx, wy) + + case 'f': # Fit the function. + + # Fit. + do i = 1, npts { + if (wts[i] > double(0.0)) + wts[i] = Memd[oldwts+i-1] + } + call in_fitd (in, nl, x, y, wts, npts, nvars, wtflag, stat) + + newgraph = YES + + case 'g': # Set graph axistype types. + call ing_defkey (in, nvars, newgraph) + + case 'h': + if (in_geti (in, INLGKEY) != 1) { + call in_puti (in, INLGKEY, 1) + newgraph = YES + } + + case 'i': + if (in_geti (in, INLGKEY) != 2) { + call in_puti (in, INLGKEY, 2) + newgraph = YES + } + + case 'j': + if (in_geti (in, INLGKEY) != 3) { + call in_puti (in, INLGKEY, 3) + newgraph = YES + } + + case 'k': + if (in_geti (in, INLGKEY) != 4) { + call in_puti (in, INLGKEY, 4) + newgraph = YES + } + + case 'l': + if (in_geti (in, INLGKEY) != 5) { + call in_puti (in, INLGKEY, 5) + newgraph = YES + } + + case 'o': # Set the overplot flag. + call in_puti (in, INLOVERPLOT, YES) + + case 'r': # Redraw the graph. + newgraph = YES + + case 't': # Toggle overplot fit flag. + if (in_geti (in, INLPLOTFIT) == YES) + call in_puti (in, INLPLOTFIT, NO) + else + call in_puti (in, INLPLOTFIT, YES) + newgraph = YES + + case 'u': # Undelete data points. + call ing_undeleted (in, gp, gt, nl, x, y, wts, Memd[oldwts], + npts, nvars, wx, wy) + + case 'w': # Window graph. + call gt_window (gt, gp, cursor, newgraph) + + case 'I': # Interrupt. + call fatal (0, "Interrupt") + + default: # Let the user decide on any other keys. + call ing_ufit (in, gp, gt, nl, wx, wy, wcs, key, Memc[cmd]) + } + + # Redraw the graph if necessary. + if (newgraph == YES) { + gkey = in_geti (in, INLGKEY) + call in_gkey (in, gkey, INLXAXIS, xt, xv) + if (xt != xtype || xv != xvar) { + call in_gkey (in, gkey, INLXAXIS, xtype, xvar) + call gt_setr (gt, GTXMIN, INDEFR) + call gt_setr (gt, GTXMAX, INDEFR) + } + call in_gkey (in, gkey, INLYAXIS, yt, yv) + if (xt != xtype || xv != xvar) { + call in_gkey (in, gkey, INLYAXIS, ytype, yvar) + call gt_setr (gt, GTYMIN, INDEFR) + call gt_setr (gt, GTYMAX, INDEFR) + } + call ing_graphd (in, gp, gt, nl, x, y, wts, npts, nvars) + newgraph = NO + } + + if (cursor[1] == EOS) + break + + } until (gt_gcur1 (gt, cursor, wx, wy, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingfitr.x b/pkg/xtools/inlfit/ingfitr.x new file mode 100644 index 00000000..9e685506 --- /dev/null +++ b/pkg/xtools/inlfit/ingfitr.x @@ -0,0 +1,204 @@ +include <error.h> +include <mach.h> +include <pkg/gtools.h> +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# IN_GFIT -- Fit a function using non-linear least squares. The function +# can have an arbitrary number of independent variables. This is the main +# entry point for the interactive part of the INLFIT package. + + +procedure ing_fitr (in, gp, cursor, gt, nl, x, y, wts, names, npts, nvars, + len_name, wtflag, stat) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +char cursor[ARB] # GIO cursor input +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +real x[ARB] # independent variables (npts * nvars) +real y[ARB] # dependent variables +real wts[ARB] # weigths +char names[ARB] # star ids +int npts # number of points +int nvars # number of variables +int len_name # length of an object name +int wtflag # type of weighting +int stat # Error code (output) + +int i, wcs, key, gkey, newgraph +int xtype, xvar, ytype, yvar, xt, xv, yt, yv +real fit +pointer sp, cmd, oldwts, help, prompt +real wx, wy + +int gt_gcur1(), ing_nearestr(), in_geti() +real nlevalr() + +begin + # Allocate string space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate and initialize a copy of the weights. A new copy + # of the weights is used because it is necessary to have the + # original values to restore them back when the user deletes + # and undeletes points. + + call salloc (oldwts, npts, TY_REAL) + call amovr (wts, Memr[oldwts], npts) + + # Allocate space for help page and prompt, and get them. + call salloc (help, SZ_LINE, TY_CHAR) + call salloc (prompt, SZ_LINE, TY_CHAR) + call in_gstr (in, INLHELP, Memc[help], SZ_LINE) + call in_gstr (in, INLPROMPT, Memc[prompt], SZ_LINE) + + # Initialize INLFIT flags. + call in_puti (in, INLOVERPLOT, NO) + + # Initialize loop control variables. The first action + # is to fit the data, in order to have all the fit + # parameters set. + key = 'f' + newgraph = YES + + # Get initial setup for axes. + gkey = in_geti (in, INLGKEY) + call in_gkey (in, gkey, INLXAXIS, xtype, xvar) + call in_gkey (in, gkey, INLYAXIS, xtype, xvar) + + # Loop reading cursor commands. + repeat { + switch (key) { + case '?': # Print help text. + call gpagefile (gp, Memc[help], Memc[prompt]) + + case ':': # List or set parameters. + if (Memc[cmd] == '/') + call gt_colon (Memc[cmd], gp, gt, newgraph) + else + call ing_colonr (in, Memc[cmd], gp, gt, nl, x, y, wts, + names, npts, nvars, len_name, newgraph) + + case 'c': # Print the positions and useful info on data points. + + i = ing_nearestr (in, gp, gt, nl, x, y, npts, nvars, wx, wy) + if (i != 0) { + fit = nlevalr (nl, x[(i-1)*nvars+1], nvars) + call printf ( + "%d %s x=%g y=%g func=%g fit=%g, resid=%g\n") + call pargi (i) + call pargstr (names[(i-1)*len_name+1]) + call pargr (wx) + call pargr (wy) + call pargr (y[i]) + call pargr (fit) + call pargr (y[i] - fit) + } + + case 'd': # Delete data points. + call ing_deleter (in, gp, gt, nl, x, y, wts, npts, nvars, + wx, wy) + + case 'f': # Fit the function. + + # Fit. + do i = 1, npts { + if (wts[i] > real(0.0)) + wts[i] = Memr[oldwts+i-1] + } + call in_fitr (in, nl, x, y, wts, npts, nvars, wtflag, stat) + + newgraph = YES + + case 'g': # Set graph axistype types. + call ing_defkey (in, nvars, newgraph) + + case 'h': + if (in_geti (in, INLGKEY) != 1) { + call in_puti (in, INLGKEY, 1) + newgraph = YES + } + + case 'i': + if (in_geti (in, INLGKEY) != 2) { + call in_puti (in, INLGKEY, 2) + newgraph = YES + } + + case 'j': + if (in_geti (in, INLGKEY) != 3) { + call in_puti (in, INLGKEY, 3) + newgraph = YES + } + + case 'k': + if (in_geti (in, INLGKEY) != 4) { + call in_puti (in, INLGKEY, 4) + newgraph = YES + } + + case 'l': + if (in_geti (in, INLGKEY) != 5) { + call in_puti (in, INLGKEY, 5) + newgraph = YES + } + + case 'o': # Set the overplot flag. + call in_puti (in, INLOVERPLOT, YES) + + case 'r': # Redraw the graph. + newgraph = YES + + case 't': # Toggle overplot fit flag. + if (in_geti (in, INLPLOTFIT) == YES) + call in_puti (in, INLPLOTFIT, NO) + else + call in_puti (in, INLPLOTFIT, YES) + newgraph = YES + + case 'u': # Undelete data points. + call ing_undeleter (in, gp, gt, nl, x, y, wts, Memr[oldwts], + npts, nvars, wx, wy) + + case 'w': # Window graph. + call gt_window (gt, gp, cursor, newgraph) + + case 'I': # Interrupt. + call fatal (0, "Interrupt") + + default: # Let the user decide on any other keys. + call ing_ufit (in, gp, gt, nl, wx, wy, wcs, key, Memc[cmd]) + } + + # Redraw the graph if necessary. + if (newgraph == YES) { + gkey = in_geti (in, INLGKEY) + call in_gkey (in, gkey, INLXAXIS, xt, xv) + if (xt != xtype || xv != xvar) { + call in_gkey (in, gkey, INLXAXIS, xtype, xvar) + call gt_setr (gt, GTXMIN, INDEFR) + call gt_setr (gt, GTXMAX, INDEFR) + } + call in_gkey (in, gkey, INLYAXIS, yt, yv) + if (xt != xtype || xv != xvar) { + call in_gkey (in, gkey, INLYAXIS, ytype, yvar) + call gt_setr (gt, GTYMIN, INDEFR) + call gt_setr (gt, GTYMAX, INDEFR) + } + call ing_graphr (in, gp, gt, nl, x, y, wts, npts, nvars) + newgraph = NO + } + + if (cursor[1] == EOS) + break + + } until (gt_gcur1 (gt, cursor, wx, wy, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/inggetlabel.x b/pkg/xtools/inlfit/inggetlabel.x new file mode 100644 index 00000000..7693b2a9 --- /dev/null +++ b/pkg/xtools/inlfit/inggetlabel.x @@ -0,0 +1,78 @@ +include <pkg/inlfit.h> + + +# ING_GETLABEL -- Get label and units for a given axis + +procedure ing_getlabel (in, xtype, xnum, label, units, maxch) + +pointer in # INLFIT descriptor +int xtype # axis type +int xnum # axis number +char label[ARB] # label +char units[ARB] # units +int maxch # max chars. in label and units + +int dummy +pointer sp, str +pointer labels, lunits, vlabels, vunits +pointer userlabels, userunits + +int inlstrwrd() + +begin + # Begin allocation of string space. + call smark (sp) + call salloc (str, SZ_LINE + 1, TY_CHAR) + + # Branch on axis type. + switch (xtype) { + case KEY_VARIABLE: + call salloc (labels, SZ_LINE, TY_CHAR) + call salloc (vlabels, SZ_LINE, TY_CHAR) + call salloc (vunits, SZ_LINE, TY_CHAR) + call in_gstr (in, INLLABELS, Memc[labels], SZ_LINE) + call in_gstr (in, INLVLABELS, Memc[vlabels], SZ_LINE) + call in_gstr (in, INLVUNITS, Memc[vunits], SZ_LINE) + + if (inlstrwrd (xnum, label, maxch, Memc[vlabels]) == 0) { + if (inlstrwrd (xtype, Memc[str], SZ_LINE, Memc[labels]) != 0) { + call sprintf (label, maxch, "%s%d") + call pargstr (Memc[str]) + call pargi (xnum) + } + } + dummy = inlstrwrd (xnum, units, maxch, Memc[vunits]) + + case KEY_FUNCTION, KEY_FIT, KEY_RESIDUALS, KEY_RATIO, KEY_NONLINEAR: + call salloc (labels, SZ_LINE, TY_CHAR) + call salloc (lunits, SZ_LINE, TY_CHAR) + call in_gstr (in, INLLABELS, Memc[labels], SZ_LINE) + call in_gstr (in, INLUNITS, Memc[lunits], SZ_LINE) + + dummy = inlstrwrd (xtype, label, maxch, Memc[labels]) + dummy = inlstrwrd (xtype, units, maxch, Memc[lunits]) + + case KEY_UAXIS: + call salloc (labels, SZ_LINE, TY_CHAR) + call salloc (userlabels, SZ_LINE, TY_CHAR) + call salloc (userunits, SZ_LINE, TY_CHAR) + call in_gstr (in, INLLABELS, Memc[labels], SZ_LINE) + call in_gstr (in, INLUSERLABELS, Memc[userlabels], SZ_LINE) + call in_gstr (in, INLUSERUNITS, Memc[userunits], SZ_LINE) + + if (inlstrwrd (xnum, label, maxch, Memc[userlabels]) == 0) { + if (inlstrwrd (xtype, Memc[str], SZ_LINE, Memc[labels]) != 0) { + call sprintf (label, maxch, "%s%d") + call pargstr (Memc[str]) + call pargi (xnum) + } + } + dummy = inlstrwrd (xnum, units, maxch, Memc[userunits]) + + default: + call error (0, "INLFIT, ing_getlabel: Unknown axis type") + } + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/inggraph.gx b/pkg/xtools/inlfit/inggraph.gx new file mode 100644 index 00000000..0eeb48d8 --- /dev/null +++ b/pkg/xtools/inlfit/inggraph.gx @@ -0,0 +1,240 @@ +include <gset.h> +include <pkg/gtools.h> +include <math/nlfit.h> +include <pkg/inlfit.h> + +define NGRAPH 100 # Number of fit points to graph +define MSIZE 3.0 # mark size for rejected points (real) + + +# ING_GRAPH -- Graph data and fit. First plot the data marking deleted +# points, then overplot rejected points, and finally overplot the fit. + +procedure ing_graph$t (in, gp, gt, nl, x, y, wts, npts, nvars) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointers +pointer nl # NLFIT pointer +PIXEL x[ARB] # Independent variables (npts * nvars) +PIXEL y[npts] # Dependent variables +PIXEL wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables + +pointer xout, yout +pointer sp + +begin + # Alloacate axes data memory. + call smark (sp) + call salloc (xout, npts, TY_PIXEL) + call salloc (yout, npts, TY_PIXEL) + + # Set axes data. + call ing_axes$t (in, gt, nl, 1, x, y, Mem$t[xout], npts, nvars) + call ing_axes$t (in, gt, nl, 2, x, y, Mem$t[yout], npts, nvars) + + # Set graphic parameters. + call ing_params$t (in, nl, x, y, wts, npts, nvars, gt) + + # Plot data and deleted points. + call ing_g1$t (in, gp, gt, Mem$t[xout], Mem$t[yout], wts, npts) + + # Overplot rejected points. + call ing_g2$t (in, gp, gt, Mem$t[xout], Mem$t[yout], npts) + + # Overplot the fit. + call ing_gf$t (in, gp, gt, nl, x, wts, npts, nvars) + + # Free memory + call sfree (sp) +end + + +# ING_G1 - Plot data and deleted points (weight = 0.0). + +procedure ing_g1$t (in, gp, gt, x, y, wts, npts) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +PIXEL x[npts] # Ordinates +PIXEL y[npts] # Abscissas +PIXEL wts[npts] # Weights +int npts # Number of points + +int i +pointer sp, xr, yr, xr1, yr1, gt1 + +int in_geti() + +begin + # Allocate memory. + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (xr1, 2, TY_REAL) + call salloc (yr1, 2, TY_REAL) + + # Change type to real for plotting. + call acht$tr (x, Memr[xr], npts) + call acht$tr (y, Memr[yr], npts) + + # Start new graph if not overplotting. + if (in_geti (in, INLOVERPLOT) == NO) { + call gclear (gp) + call gascale (gp, Memr[xr], npts, 1) + call gascale (gp, Memr[yr], npts, 2) + call gt_swind (gp, gt) + call gt_labax (gp, gt) + } + + # Initialize auxiliaray GTOOLS descriptor for deleted points. + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "cross") + + # Plot data points marking deleted points with other symbol. + Memr[xr1] = Memr[xr] + Memr[yr1] = Memr[yr] + do i = 1, npts { + if (wts[i] == PIXEL (0.0)) { + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } else { +# Memr[xr1+1] = Memr[xr+i-1] +# Memr[yr1+1] = Memr[yr+i-1] +# call gt_plot (gp, gt, Memr[xr1], Memr[yr1], 2) +# Memr[xr1] = Memr[xr1+1] +# Memr[yr1] = Memr[yr1+1] + + call gt_plot (gp, gt, Memr[xr+i-1], Memr[yr+i-1], 1) + } + } + + # Reset overplot flag. + call in_puti (in, INLOVERPLOT, NO) + + # Free memory and auxiliary GTOOLS descriptor. + call sfree (sp) + call gt_free (gt1) +end + + +# ING_G2 - Overplot rejected points. + +procedure ing_g2$t (in, gp, gt, x, y, npts) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +PIXEL x[npts], y[npts] # Data points +int npts # Number of data points + +int i +pointer sp, xr, yr, gt1 +pointer rejpts + +int in_geti() +int in_getp() + +begin + # Don't plot if there are no rejected points + if (in_geti (in, INLNREJPTS) == 0) + return + + # Allocate axes memory. + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + + # Change type to real for plotting. + call acht$tr (x, Memr[xr], npts) + call acht$tr (y, Memr[yr], npts) + + # Initialize auxiliary GTOOLS descriptor + # for rejected points. + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "diamond") + call gt_setr (gt1, GTXSIZE, MSIZE) + call gt_setr (gt1, GTYSIZE, MSIZE) + + # Plot rejected points if there are any. + rejpts = in_getp (in, INLREJPTS) + do i = 1, npts { + if (Memi[rejpts + i - 1] == YES) + call gt_plot (gp, gt1, Memr[xr + i - 1], Memr[yr + i - 1], 1) + } + + # Free memory and auxiliary GTOOLS descriptor. + call gt_free (gt1) + call sfree (sp) +end + + +# ING_GF - Overplot the fit using dashed lines. + +procedure ing_gf$t (in, gp, gt, nl, xin, wts, npts, nvars) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOL pointer +pointer nl # NLFIT pointer +PIXEL xin[ARB] # Independent variables +PIXEL wts[npts] # weights +int npts # Number of points to plot +int nvars # Number of variables + +int i +pointer sp, xr, yr, x, y, xo, yo, gt1 + +int in_geti() + +begin + # Don't plot if there is a fit error. + if (in_geti (in, INLFITERROR) != DONE || + in_geti (in, INLPLOTFIT) == NO) + return + + # Allocate memory. + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (x, npts * nvars, TY_PIXEL) + call salloc (y, npts, TY_PIXEL) + call salloc (xo, npts, TY_PIXEL) + call salloc (yo, npts, TY_PIXEL) + + # Move input data into vector. + call amov$t (xin, Mem$t[x], npts * nvars) + + # Calculate vector of fit values. + call nlvector$t (nl, Mem$t[x], Mem$t[y], npts, nvars) + + # Set axes data. + call ing_axes$t (in, gt, nl, 1, Mem$t[x], Mem$t[y], Mem$t[xo], + npts, nvars) + call ing_axes$t (in, gt, nl, 2, Mem$t[x], Mem$t[y], Mem$t[yo], + npts, nvars) + + # Convert to real for plotting. + call acht$tr (Mem$t[xo], Memr[xr], npts) + call acht$tr (Mem$t[yo], Memr[yr], npts) + + # Initialize auxiliary GTOOLS descriptor, plot the + # fit and free the auxiliary descriptor. + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "box") + call gt_setr (gt1, GTXSIZE, MSIZE) + call gt_setr (gt1, GTXSIZE, MSIZE) + do i = 1, npts { + if (wts[i] != PIXEL (0.0)) + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } + call gt_free (gt1) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/inggraphd.x b/pkg/xtools/inlfit/inggraphd.x new file mode 100644 index 00000000..245afa63 --- /dev/null +++ b/pkg/xtools/inlfit/inggraphd.x @@ -0,0 +1,240 @@ +include <gset.h> +include <pkg/gtools.h> +include <math/nlfit.h> +include <pkg/inlfit.h> + +define NGRAPH 100 # Number of fit points to graph +define MSIZE 3.0 # mark size for rejected points (real) + + +# ING_GRAPH -- Graph data and fit. First plot the data marking deleted +# points, then overplot rejected points, and finally overplot the fit. + +procedure ing_graphd (in, gp, gt, nl, x, y, wts, npts, nvars) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointers +pointer nl # NLFIT pointer +double x[ARB] # Independent variables (npts * nvars) +double y[npts] # Dependent variables +double wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables + +pointer xout, yout +pointer sp + +begin + # Alloacate axes data memory. + call smark (sp) + call salloc (xout, npts, TY_DOUBLE) + call salloc (yout, npts, TY_DOUBLE) + + # Set axes data. + call ing_axesd (in, gt, nl, 1, x, y, Memd[xout], npts, nvars) + call ing_axesd (in, gt, nl, 2, x, y, Memd[yout], npts, nvars) + + # Set graphic parameters. + call ing_paramsd (in, nl, x, y, wts, npts, nvars, gt) + + # Plot data and deleted points. + call ing_g1d (in, gp, gt, Memd[xout], Memd[yout], wts, npts) + + # Overplot rejected points. + call ing_g2d (in, gp, gt, Memd[xout], Memd[yout], npts) + + # Overplot the fit. + call ing_gfd (in, gp, gt, nl, x, wts, npts, nvars) + + # Free memory + call sfree (sp) +end + + +# ING_G1 - Plot data and deleted points (weight = 0.0). + +procedure ing_g1d (in, gp, gt, x, y, wts, npts) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +double x[npts] # Ordinates +double y[npts] # Abscissas +double wts[npts] # Weights +int npts # Number of points + +int i +pointer sp, xr, yr, xr1, yr1, gt1 + +int in_geti() + +begin + # Allocate memory. + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (xr1, 2, TY_REAL) + call salloc (yr1, 2, TY_REAL) + + # Change type to real for plotting. + call achtdr (x, Memr[xr], npts) + call achtdr (y, Memr[yr], npts) + + # Start new graph if not overplotting. + if (in_geti (in, INLOVERPLOT) == NO) { + call gclear (gp) + call gascale (gp, Memr[xr], npts, 1) + call gascale (gp, Memr[yr], npts, 2) + call gt_swind (gp, gt) + call gt_labax (gp, gt) + } + + # Initialize auxiliaray GTOOLS descriptor for deleted points. + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "cross") + + # Plot data points marking deleted points with other symbol. + Memr[xr1] = Memr[xr] + Memr[yr1] = Memr[yr] + do i = 1, npts { + if (wts[i] == double (0.0)) { + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } else { +# Memr[xr1+1] = Memr[xr+i-1] +# Memr[yr1+1] = Memr[yr+i-1] +# call gt_plot (gp, gt, Memr[xr1], Memr[yr1], 2) +# Memr[xr1] = Memr[xr1+1] +# Memr[yr1] = Memr[yr1+1] + + call gt_plot (gp, gt, Memr[xr+i-1], Memr[yr+i-1], 1) + } + } + + # Reset overplot flag. + call in_puti (in, INLOVERPLOT, NO) + + # Free memory and auxiliary GTOOLS descriptor. + call sfree (sp) + call gt_free (gt1) +end + + +# ING_G2 - Overplot rejected points. + +procedure ing_g2d (in, gp, gt, x, y, npts) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +double x[npts], y[npts] # Data points +int npts # Number of data points + +int i +pointer sp, xr, yr, gt1 +pointer rejpts + +int in_geti() +int in_getp() + +begin + # Don't plot if there are no rejected points + if (in_geti (in, INLNREJPTS) == 0) + return + + # Allocate axes memory. + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + + # Change type to real for plotting. + call achtdr (x, Memr[xr], npts) + call achtdr (y, Memr[yr], npts) + + # Initialize auxiliary GTOOLS descriptor + # for rejected points. + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "diamond") + call gt_setr (gt1, GTXSIZE, MSIZE) + call gt_setr (gt1, GTYSIZE, MSIZE) + + # Plot rejected points if there are any. + rejpts = in_getp (in, INLREJPTS) + do i = 1, npts { + if (Memi[rejpts + i - 1] == YES) + call gt_plot (gp, gt1, Memr[xr + i - 1], Memr[yr + i - 1], 1) + } + + # Free memory and auxiliary GTOOLS descriptor. + call gt_free (gt1) + call sfree (sp) +end + + +# ING_GF - Overplot the fit using dashed lines. + +procedure ing_gfd (in, gp, gt, nl, xin, wts, npts, nvars) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOL pointer +pointer nl # NLFIT pointer +double xin[ARB] # Independent variables +double wts[npts] # weights +int npts # Number of points to plot +int nvars # Number of variables + +int i +pointer sp, xr, yr, x, y, xo, yo, gt1 + +int in_geti() + +begin + # Don't plot if there is a fit error. + if (in_geti (in, INLFITERROR) != DONE || + in_geti (in, INLPLOTFIT) == NO) + return + + # Allocate memory. + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (x, npts * nvars, TY_DOUBLE) + call salloc (y, npts, TY_DOUBLE) + call salloc (xo, npts, TY_DOUBLE) + call salloc (yo, npts, TY_DOUBLE) + + # Move input data into vector. + call amovd (xin, Memd[x], npts * nvars) + + # Calculate vector of fit values. + call nlvectord (nl, Memd[x], Memd[y], npts, nvars) + + # Set axes data. + call ing_axesd (in, gt, nl, 1, Memd[x], Memd[y], Memd[xo], + npts, nvars) + call ing_axesd (in, gt, nl, 2, Memd[x], Memd[y], Memd[yo], + npts, nvars) + + # Convert to real for plotting. + call achtdr (Memd[xo], Memr[xr], npts) + call achtdr (Memd[yo], Memr[yr], npts) + + # Initialize auxiliary GTOOLS descriptor, plot the + # fit and free the auxiliary descriptor. + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "box") + call gt_setr (gt1, GTXSIZE, MSIZE) + call gt_setr (gt1, GTXSIZE, MSIZE) + do i = 1, npts { + if (wts[i] != double (0.0)) + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } + call gt_free (gt1) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/inggraphr.x b/pkg/xtools/inlfit/inggraphr.x new file mode 100644 index 00000000..6ddac343 --- /dev/null +++ b/pkg/xtools/inlfit/inggraphr.x @@ -0,0 +1,240 @@ +include <gset.h> +include <pkg/gtools.h> +include <math/nlfit.h> +include <pkg/inlfit.h> + +define NGRAPH 100 # Number of fit points to graph +define MSIZE 3.0 # mark size for rejected points (real) + + +# ING_GRAPH -- Graph data and fit. First plot the data marking deleted +# points, then overplot rejected points, and finally overplot the fit. + +procedure ing_graphr (in, gp, gt, nl, x, y, wts, npts, nvars) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointers +pointer nl # NLFIT pointer +real x[ARB] # Independent variables (npts * nvars) +real y[npts] # Dependent variables +real wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables + +pointer xout, yout +pointer sp + +begin + # Alloacate axes data memory. + call smark (sp) + call salloc (xout, npts, TY_REAL) + call salloc (yout, npts, TY_REAL) + + # Set axes data. + call ing_axesr (in, gt, nl, 1, x, y, Memr[xout], npts, nvars) + call ing_axesr (in, gt, nl, 2, x, y, Memr[yout], npts, nvars) + + # Set graphic parameters. + call ing_paramsr (in, nl, x, y, wts, npts, nvars, gt) + + # Plot data and deleted points. + call ing_g1r (in, gp, gt, Memr[xout], Memr[yout], wts, npts) + + # Overplot rejected points. + call ing_g2r (in, gp, gt, Memr[xout], Memr[yout], npts) + + # Overplot the fit. + call ing_gfr (in, gp, gt, nl, x, wts, npts, nvars) + + # Free memory + call sfree (sp) +end + + +# ING_G1 - Plot data and deleted points (weight = 0.0). + +procedure ing_g1r (in, gp, gt, x, y, wts, npts) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +real x[npts] # Ordinates +real y[npts] # Abscissas +real wts[npts] # Weights +int npts # Number of points + +int i +pointer sp, xr, yr, xr1, yr1, gt1 + +int in_geti() + +begin + # Allocate memory. + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (xr1, 2, TY_REAL) + call salloc (yr1, 2, TY_REAL) + + # Change type to real for plotting. + call achtrr (x, Memr[xr], npts) + call achtrr (y, Memr[yr], npts) + + # Start new graph if not overplotting. + if (in_geti (in, INLOVERPLOT) == NO) { + call gclear (gp) + call gascale (gp, Memr[xr], npts, 1) + call gascale (gp, Memr[yr], npts, 2) + call gt_swind (gp, gt) + call gt_labax (gp, gt) + } + + # Initialize auxiliaray GTOOLS descriptor for deleted points. + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "cross") + + # Plot data points marking deleted points with other symbol. + Memr[xr1] = Memr[xr] + Memr[yr1] = Memr[yr] + do i = 1, npts { + if (wts[i] == real (0.0)) { + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } else { +# Memr[xr1+1] = Memr[xr+i-1] +# Memr[yr1+1] = Memr[yr+i-1] +# call gt_plot (gp, gt, Memr[xr1], Memr[yr1], 2) +# Memr[xr1] = Memr[xr1+1] +# Memr[yr1] = Memr[yr1+1] + + call gt_plot (gp, gt, Memr[xr+i-1], Memr[yr+i-1], 1) + } + } + + # Reset overplot flag. + call in_puti (in, INLOVERPLOT, NO) + + # Free memory and auxiliary GTOOLS descriptor. + call sfree (sp) + call gt_free (gt1) +end + + +# ING_G2 - Overplot rejected points. + +procedure ing_g2r (in, gp, gt, x, y, npts) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +real x[npts], y[npts] # Data points +int npts # Number of data points + +int i +pointer sp, xr, yr, gt1 +pointer rejpts + +int in_geti() +int in_getp() + +begin + # Don't plot if there are no rejected points + if (in_geti (in, INLNREJPTS) == 0) + return + + # Allocate axes memory. + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + + # Change type to real for plotting. + call achtrr (x, Memr[xr], npts) + call achtrr (y, Memr[yr], npts) + + # Initialize auxiliary GTOOLS descriptor + # for rejected points. + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "diamond") + call gt_setr (gt1, GTXSIZE, MSIZE) + call gt_setr (gt1, GTYSIZE, MSIZE) + + # Plot rejected points if there are any. + rejpts = in_getp (in, INLREJPTS) + do i = 1, npts { + if (Memi[rejpts + i - 1] == YES) + call gt_plot (gp, gt1, Memr[xr + i - 1], Memr[yr + i - 1], 1) + } + + # Free memory and auxiliary GTOOLS descriptor. + call gt_free (gt1) + call sfree (sp) +end + + +# ING_GF - Overplot the fit using dashed lines. + +procedure ing_gfr (in, gp, gt, nl, xin, wts, npts, nvars) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOL pointer +pointer nl # NLFIT pointer +real xin[ARB] # Independent variables +real wts[npts] # weights +int npts # Number of points to plot +int nvars # Number of variables + +int i +pointer sp, xr, yr, x, y, xo, yo, gt1 + +int in_geti() + +begin + # Don't plot if there is a fit error. + if (in_geti (in, INLFITERROR) != DONE || + in_geti (in, INLPLOTFIT) == NO) + return + + # Allocate memory. + call smark (sp) + call salloc (xr, npts, TY_REAL) + call salloc (yr, npts, TY_REAL) + call salloc (x, npts * nvars, TY_REAL) + call salloc (y, npts, TY_REAL) + call salloc (xo, npts, TY_REAL) + call salloc (yo, npts, TY_REAL) + + # Move input data into vector. + call amovr (xin, Memr[x], npts * nvars) + + # Calculate vector of fit values. + call nlvectorr (nl, Memr[x], Memr[y], npts, nvars) + + # Set axes data. + call ing_axesr (in, gt, nl, 1, Memr[x], Memr[y], Memr[xo], + npts, nvars) + call ing_axesr (in, gt, nl, 2, Memr[x], Memr[y], Memr[yo], + npts, nvars) + + # Convert to real for plotting. + call achtrr (Memr[xo], Memr[xr], npts) + call achtrr (Memr[yo], Memr[yr], npts) + + # Initialize auxiliary GTOOLS descriptor, plot the + # fit and free the auxiliary descriptor. + call gt_copy (gt, gt1) + call gt_sets (gt1, GTTYPE, "mark") + call gt_sets (gt1, GTMARK, "box") + call gt_setr (gt1, GTXSIZE, MSIZE) + call gt_setr (gt1, GTXSIZE, MSIZE) + do i = 1, npts { + if (wts[i] != real (0.0)) + call gt_plot (gp, gt1, Memr[xr+i-1], Memr[yr+i-1], 1) + } + call gt_free (gt1) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingnearest.gx b/pkg/xtools/inlfit/ingnearest.gx new file mode 100644 index 00000000..1d208678 --- /dev/null +++ b/pkg/xtools/inlfit/ingnearest.gx @@ -0,0 +1,81 @@ +include <mach.h> +include <pkg/gtools.h> + + +# ING_NEAREST -- Find the nearest point to the cursor and return the index. +# The cursor is moved to the nearest point selected. + +int procedure ing_nearest$t (in, gp, gt, nl, x, y, npts, nvars, wx, wy) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +PIXEL x[ARB] # Independent variables (npts * nvars) +PIXEL y[npts] # Dependent variables +int npts # Number of points +int nvars # Number of variables +real wx, wy # Cursor position + +int pt +pointer sp, xout, yout + +int ing_n$t(), gt_geti() + +begin + # Allocate memory for axes data + call smark (sp) + call salloc (xout, npts, TY_PIXEL) + call salloc (yout, npts, TY_PIXEL) + + # Set axes data + call ing_axes$t (in, gt, nl, 1, x, y, Mem$t[xout], npts, nvars) + call ing_axes$t (in, gt, nl, 2, x, y, Mem$t[yout], npts, nvars) + + # Check for transposed axes + if (gt_geti (gt, GTTRANSPOSE) == NO) + pt = ing_n$t (gp, Mem$t[xout], Mem$t[yout], npts, wx, wy) + else + pt = ing_n$t (gp, Mem$t[yout], Mem$t[xout], npts, wy, wx) + call sfree (sp) + + # Return index + return (pt) +end + + +# ING_N -- Find position and move the cursor. + +int procedure ing_n$t (gp, x, y, npts, wx, wy) + +pointer gp # GIO pointer +PIXEL x[npts], y[npts] # Data points +int npts # Number of points +real wx, wy # Cursor position + +int i, j +real xc, yc, x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + call gctran (gp, wx, wy, xc, yc, 1, 0) + + # Search for nearest point. + r2min = MAX_REAL + do i = 1, npts { + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + r2 = (x0 - xc) ** 2 + (y0 - yc) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Move the cursor to the selected point and return the index. + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + wx = x[j] + wy = y[j] + } + return (j) +end diff --git a/pkg/xtools/inlfit/ingnearestd.x b/pkg/xtools/inlfit/ingnearestd.x new file mode 100644 index 00000000..d27f7a6b --- /dev/null +++ b/pkg/xtools/inlfit/ingnearestd.x @@ -0,0 +1,81 @@ +include <mach.h> +include <pkg/gtools.h> + + +# ING_NEAREST -- Find the nearest point to the cursor and return the index. +# The cursor is moved to the nearest point selected. + +int procedure ing_nearestd (in, gp, gt, nl, x, y, npts, nvars, wx, wy) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +double x[ARB] # Independent variables (npts * nvars) +double y[npts] # Dependent variables +int npts # Number of points +int nvars # Number of variables +real wx, wy # Cursor position + +int pt +pointer sp, xout, yout + +int ing_nd(), gt_geti() + +begin + # Allocate memory for axes data + call smark (sp) + call salloc (xout, npts, TY_DOUBLE) + call salloc (yout, npts, TY_DOUBLE) + + # Set axes data + call ing_axesd (in, gt, nl, 1, x, y, Memd[xout], npts, nvars) + call ing_axesd (in, gt, nl, 2, x, y, Memd[yout], npts, nvars) + + # Check for transposed axes + if (gt_geti (gt, GTTRANSPOSE) == NO) + pt = ing_nd (gp, Memd[xout], Memd[yout], npts, wx, wy) + else + pt = ing_nd (gp, Memd[yout], Memd[xout], npts, wy, wx) + call sfree (sp) + + # Return index + return (pt) +end + + +# ING_N -- Find position and move the cursor. + +int procedure ing_nd (gp, x, y, npts, wx, wy) + +pointer gp # GIO pointer +double x[npts], y[npts] # Data points +int npts # Number of points +real wx, wy # Cursor position + +int i, j +real xc, yc, x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + call gctran (gp, wx, wy, xc, yc, 1, 0) + + # Search for nearest point. + r2min = MAX_REAL + do i = 1, npts { + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + r2 = (x0 - xc) ** 2 + (y0 - yc) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Move the cursor to the selected point and return the index. + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + wx = x[j] + wy = y[j] + } + return (j) +end diff --git a/pkg/xtools/inlfit/ingnearestr.x b/pkg/xtools/inlfit/ingnearestr.x new file mode 100644 index 00000000..2ac7de51 --- /dev/null +++ b/pkg/xtools/inlfit/ingnearestr.x @@ -0,0 +1,81 @@ +include <mach.h> +include <pkg/gtools.h> + + +# ING_NEAREST -- Find the nearest point to the cursor and return the index. +# The cursor is moved to the nearest point selected. + +int procedure ing_nearestr (in, gp, gt, nl, x, y, npts, nvars, wx, wy) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +real x[ARB] # Independent variables (npts * nvars) +real y[npts] # Dependent variables +int npts # Number of points +int nvars # Number of variables +real wx, wy # Cursor position + +int pt +pointer sp, xout, yout + +int ing_nr(), gt_geti() + +begin + # Allocate memory for axes data + call smark (sp) + call salloc (xout, npts, TY_REAL) + call salloc (yout, npts, TY_REAL) + + # Set axes data + call ing_axesr (in, gt, nl, 1, x, y, Memr[xout], npts, nvars) + call ing_axesr (in, gt, nl, 2, x, y, Memr[yout], npts, nvars) + + # Check for transposed axes + if (gt_geti (gt, GTTRANSPOSE) == NO) + pt = ing_nr (gp, Memr[xout], Memr[yout], npts, wx, wy) + else + pt = ing_nr (gp, Memr[yout], Memr[xout], npts, wy, wx) + call sfree (sp) + + # Return index + return (pt) +end + + +# ING_N -- Find position and move the cursor. + +int procedure ing_nr (gp, x, y, npts, wx, wy) + +pointer gp # GIO pointer +real x[npts], y[npts] # Data points +int npts # Number of points +real wx, wy # Cursor position + +int i, j +real xc, yc, x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + call gctran (gp, wx, wy, xc, yc, 1, 0) + + # Search for nearest point. + r2min = MAX_REAL + do i = 1, npts { + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + r2 = (x0 - xc) ** 2 + (y0 - yc) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Move the cursor to the selected point and return the index. + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + wx = x[j] + wy = y[j] + } + return (j) +end diff --git a/pkg/xtools/inlfit/ingparams.gx b/pkg/xtools/inlfit/ingparams.gx new file mode 100644 index 00000000..e250d681 --- /dev/null +++ b/pkg/xtools/inlfit/ingparams.gx @@ -0,0 +1,120 @@ +include <pkg/gtools.h> +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# ING_PARAMS -- Set parameter string. + +procedure ing_params$t (in, nl, x, y, wts, npts, nvars, gt) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +PIXEL x[ARB] # Ordinates (npts * nvars) +PIXEL y[ARB] # Abscissas +PIXEL wts[ARB] # Weights +int npts # Number of data points +int nvars # Number of variables +pointer gt # GTOOLS pointer + +int i, rejected, deleted, length +int len3, len4 +PIXEL rms +pointer sp, fit, wts1, rejpts +pointer str1, str2, str3, str4, line + +int strlen() +int nlstati() +int inlstrwrd() +int in_geti() +PIXEL nlstat$t() +PIXEL in_rms$t() +PIXEL in_get$t() +pointer in_getp() + +begin + # Allocate memory + call smark (sp) + call salloc (fit, npts, TY_PIXEL) + call salloc (wts1, npts, TY_PIXEL) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + call salloc (str3, SZ_LINE, TY_CHAR) + call salloc (str4, SZ_LINE, TY_CHAR) + + # Mark rejected points as deleted for rms comnputation, + # and count number of deleted points. + call amov$t (wts, Mem$t[wts1], npts) + rejected = in_geti (in, INLNREJPTS) + rejpts = in_getp (in, INLREJPTS) + if (rejected > 0) { + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Mem$t[wts1+i-1] = PIXEL (0.0) + } + } + deleted = 0 + do i = 1, npts { + if (wts[i] == PIXEL (0.0)) + deleted = deleted + 1 + } + + # Set the fit and compute the RMS error. + if (in_geti (in, INLFITERROR) == DONE) { + call nlvector$t (nl, x, Mem$t[fit], npts, nvars) + rms = in_rms$t (y, Mem$t[fit], Mem$t[wts1], npts) + } else + rms = INDEF + + # Build interactive graphics and NLFIT parameter strings + call sprintf (Memc[str1], SZ_LINE, + #"low_rej=%7.4g, high_rej=%7.4g, nreject=%d, grow=%7.4g") + "low_rej=%.4g, high_rej=%.4g, nreject=%d, grow=%.4g") + call parg$t (in_get$t (in, INLLOW)) + call parg$t (in_get$t (in, INLHIGH)) + call pargi (in_geti (in, INLNREJECT)) + call parg$t (in_get$t (in, INLGROW)) + call sprintf (Memc[str2], SZ_LINE, + #"total=%d, rejected=%d, deleted=%d, RMS=%7.4g") + "total=%d, rejected=%d, deleted=%d, RMS=%.4g") + call pargi (npts) + call pargi (rejected) + call pargi (deleted) + call parg$t (rms) + call sprintf (Memc[str3], SZ_LINE, + #"tolerance=%7.4g, maxiter=%d, iterations=%d") + "tolerance=%.4g, maxiter=%d, iterations=%d") + call parg$t (nlstat$t (nl, NLTOL)) + call pargi (nlstati (nl, NLITMAX)) + call pargi (nlstati (nl, NLITER)) + + # Set the output parameter line. + length = strlen (Memc[str1]) + strlen (Memc[str2]) + + strlen (Memc[str3]) + 3 + call salloc (line, length + 1, TY_CHAR) + call sprintf (Memc[line], length, "%s\n%s\n%s") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargstr (Memc[str3]) + call gt_sets (gt, GTPARAMS, Memc[line]) + + # Get the error and function label strings. + call nlerrmsg (in_geti (in, INLFITERROR), Memc[str1], SZ_LINE) + call in_gstr (in, INLFLABELS, Memc[str2], SZ_LINE) + + # Set the output title line. + len3 = inlstrwrd (1, Memc[str3], SZ_LINE, Memc[str2]) + len4 = inlstrwrd (2, Memc[str4], SZ_LINE, Memc[str2]) + if (len3 != 0 && len4 != 0) { + call sprintf (Memc[line], length, "%s = %s\n%s") + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + call pargstr (Memc[str1]) + } else { + call sprintf (Memc[line], length, "%s") + call pargstr (Memc[str2]) + } + call gt_sets (gt, GTTITLE, Memc[line]) + + # Free allocated memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingparamsd.x b/pkg/xtools/inlfit/ingparamsd.x new file mode 100644 index 00000000..eceea41c --- /dev/null +++ b/pkg/xtools/inlfit/ingparamsd.x @@ -0,0 +1,120 @@ +include <pkg/gtools.h> +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# ING_PARAMS -- Set parameter string. + +procedure ing_paramsd (in, nl, x, y, wts, npts, nvars, gt) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +double x[ARB] # Ordinates (npts * nvars) +double y[ARB] # Abscissas +double wts[ARB] # Weights +int npts # Number of data points +int nvars # Number of variables +pointer gt # GTOOLS pointer + +int i, rejected, deleted, length +int len3, len4 +double rms +pointer sp, fit, wts1, rejpts +pointer str1, str2, str3, str4, line + +int strlen() +int nlstati() +int inlstrwrd() +int in_geti() +double nlstatd() +double in_rmsd() +double in_getd() +pointer in_getp() + +begin + # Allocate memory + call smark (sp) + call salloc (fit, npts, TY_DOUBLE) + call salloc (wts1, npts, TY_DOUBLE) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + call salloc (str3, SZ_LINE, TY_CHAR) + call salloc (str4, SZ_LINE, TY_CHAR) + + # Mark rejected points as deleted for rms comnputation, + # and count number of deleted points. + call amovd (wts, Memd[wts1], npts) + rejected = in_geti (in, INLNREJPTS) + rejpts = in_getp (in, INLREJPTS) + if (rejected > 0) { + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Memd[wts1+i-1] = double (0.0) + } + } + deleted = 0 + do i = 1, npts { + if (wts[i] == double (0.0)) + deleted = deleted + 1 + } + + # Set the fit and compute the RMS error. + if (in_geti (in, INLFITERROR) == DONE) { + call nlvectord (nl, x, Memd[fit], npts, nvars) + rms = in_rmsd (y, Memd[fit], Memd[wts1], npts) + } else + rms = INDEFD + + # Build interactive graphics and NLFIT parameter strings + call sprintf (Memc[str1], SZ_LINE, + #"low_rej=%7.4g, high_rej=%7.4g, nreject=%d, grow=%7.4g") + "low_rej=%.4g, high_rej=%.4g, nreject=%d, grow=%.4g") + call pargd (in_getd (in, INLLOW)) + call pargd (in_getd (in, INLHIGH)) + call pargi (in_geti (in, INLNREJECT)) + call pargd (in_getd (in, INLGROW)) + call sprintf (Memc[str2], SZ_LINE, + #"total=%d, rejected=%d, deleted=%d, RMS=%7.4g") + "total=%d, rejected=%d, deleted=%d, RMS=%.4g") + call pargi (npts) + call pargi (rejected) + call pargi (deleted) + call pargd (rms) + call sprintf (Memc[str3], SZ_LINE, + #"tolerance=%7.4g, maxiter=%d, iterations=%d") + "tolerance=%.4g, maxiter=%d, iterations=%d") + call pargd (nlstatd (nl, NLTOL)) + call pargi (nlstati (nl, NLITMAX)) + call pargi (nlstati (nl, NLITER)) + + # Set the output parameter line. + length = strlen (Memc[str1]) + strlen (Memc[str2]) + + strlen (Memc[str3]) + 3 + call salloc (line, length + 1, TY_CHAR) + call sprintf (Memc[line], length, "%s\n%s\n%s") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargstr (Memc[str3]) + call gt_sets (gt, GTPARAMS, Memc[line]) + + # Get the error and function label strings. + call nlerrmsg (in_geti (in, INLFITERROR), Memc[str1], SZ_LINE) + call in_gstr (in, INLFLABELS, Memc[str2], SZ_LINE) + + # Set the output title line. + len3 = inlstrwrd (1, Memc[str3], SZ_LINE, Memc[str2]) + len4 = inlstrwrd (2, Memc[str4], SZ_LINE, Memc[str2]) + if (len3 != 0 && len4 != 0) { + call sprintf (Memc[line], length, "%s = %s\n%s") + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + call pargstr (Memc[str1]) + } else { + call sprintf (Memc[line], length, "%s") + call pargstr (Memc[str2]) + } + call gt_sets (gt, GTTITLE, Memc[line]) + + # Free allocated memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingparamsr.x b/pkg/xtools/inlfit/ingparamsr.x new file mode 100644 index 00000000..53f9ffc9 --- /dev/null +++ b/pkg/xtools/inlfit/ingparamsr.x @@ -0,0 +1,120 @@ +include <pkg/gtools.h> +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# ING_PARAMS -- Set parameter string. + +procedure ing_paramsr (in, nl, x, y, wts, npts, nvars, gt) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +real x[ARB] # Ordinates (npts * nvars) +real y[ARB] # Abscissas +real wts[ARB] # Weights +int npts # Number of data points +int nvars # Number of variables +pointer gt # GTOOLS pointer + +int i, rejected, deleted, length +int len3, len4 +real rms +pointer sp, fit, wts1, rejpts +pointer str1, str2, str3, str4, line + +int strlen() +int nlstati() +int inlstrwrd() +int in_geti() +real nlstatr() +real in_rmsr() +real in_getr() +pointer in_getp() + +begin + # Allocate memory + call smark (sp) + call salloc (fit, npts, TY_REAL) + call salloc (wts1, npts, TY_REAL) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + call salloc (str3, SZ_LINE, TY_CHAR) + call salloc (str4, SZ_LINE, TY_CHAR) + + # Mark rejected points as deleted for rms comnputation, + # and count number of deleted points. + call amovr (wts, Memr[wts1], npts) + rejected = in_geti (in, INLNREJPTS) + rejpts = in_getp (in, INLREJPTS) + if (rejected > 0) { + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Memr[wts1+i-1] = real (0.0) + } + } + deleted = 0 + do i = 1, npts { + if (wts[i] == real (0.0)) + deleted = deleted + 1 + } + + # Set the fit and compute the RMS error. + if (in_geti (in, INLFITERROR) == DONE) { + call nlvectorr (nl, x, Memr[fit], npts, nvars) + rms = in_rmsr (y, Memr[fit], Memr[wts1], npts) + } else + rms = INDEFR + + # Build interactive graphics and NLFIT parameter strings + call sprintf (Memc[str1], SZ_LINE, + #"low_rej=%7.4g, high_rej=%7.4g, nreject=%d, grow=%7.4g") + "low_rej=%.4g, high_rej=%.4g, nreject=%d, grow=%.4g") + call pargr (in_getr (in, INLLOW)) + call pargr (in_getr (in, INLHIGH)) + call pargi (in_geti (in, INLNREJECT)) + call pargr (in_getr (in, INLGROW)) + call sprintf (Memc[str2], SZ_LINE, + #"total=%d, rejected=%d, deleted=%d, RMS=%7.4g") + "total=%d, rejected=%d, deleted=%d, RMS=%.4g") + call pargi (npts) + call pargi (rejected) + call pargi (deleted) + call pargr (rms) + call sprintf (Memc[str3], SZ_LINE, + #"tolerance=%7.4g, maxiter=%d, iterations=%d") + "tolerance=%.4g, maxiter=%d, iterations=%d") + call pargr (nlstatr (nl, NLTOL)) + call pargi (nlstati (nl, NLITMAX)) + call pargi (nlstati (nl, NLITER)) + + # Set the output parameter line. + length = strlen (Memc[str1]) + strlen (Memc[str2]) + + strlen (Memc[str3]) + 3 + call salloc (line, length + 1, TY_CHAR) + call sprintf (Memc[line], length, "%s\n%s\n%s") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargstr (Memc[str3]) + call gt_sets (gt, GTPARAMS, Memc[line]) + + # Get the error and function label strings. + call nlerrmsg (in_geti (in, INLFITERROR), Memc[str1], SZ_LINE) + call in_gstr (in, INLFLABELS, Memc[str2], SZ_LINE) + + # Set the output title line. + len3 = inlstrwrd (1, Memc[str3], SZ_LINE, Memc[str2]) + len4 = inlstrwrd (2, Memc[str4], SZ_LINE, Memc[str2]) + if (len3 != 0 && len4 != 0) { + call sprintf (Memc[line], length, "%s = %s\n%s") + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + call pargstr (Memc[str1]) + } else { + call sprintf (Memc[line], length, "%s") + call pargstr (Memc[str2]) + } + call gt_sets (gt, GTTITLE, Memc[line]) + + # Free allocated memory. + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingresults.gx b/pkg/xtools/inlfit/ingresults.gx new file mode 100644 index 00000000..6582bd35 --- /dev/null +++ b/pkg/xtools/inlfit/ingresults.gx @@ -0,0 +1,85 @@ +include <pkg/inlfit.h> + +# ING_RESULTS -- Print the results of the fit. + +procedure ing_results$t (in, file, nl, x, y, wts, names, npts, nvars, len_name) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +pointer nl # NLFIT pointer +PIXEL x[ARB] # Ordinates (npts * nvars) +PIXEL y[ARB] # Abscissas +PIXEL wts[ARB] # Weights +char names[ARB] # Object names +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of a name + +int i, fd, rejected +pointer sp, fit, wts1, rejpts +int open(), in_geti() +pointer in_getp() +errchk open + +begin + # Open the output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Test the number of points. + if (npts == 0) { + call eprintf ("Incomplete output - no data points for fit\n") + return + } + + # Allocate memory. + call smark (sp) + call salloc (fit, npts, TY_PIXEL) + call salloc (wts1, npts, TY_PIXEL) + + # Evaluate the fit. + call nlvector$t (nl, x, Mem$t[fit], npts, nvars) + + # Assign a zero weight to the rejected points. + rejected = in_geti (in, INLNREJPTS) + rejpts = in_getp (in, INLREJPTS) + call amov$t (wts, Mem$t[wts1], npts) + if (rejected > 0) { + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Mem$t[wts1+i-1] = PIXEL (0.0) + } + } + + # Print the title. + call fprintf (fd, "\n#%14.14s %14.14s %14.14s") + call pargstr ("objectid") + call pargstr ("function") + call pargstr ("fit") + call fprintf (fd, " %14.14s %14.14s\n") + call pargstr ("residuals") + call pargstr ("sigma") + + # List function value, fit value, residual and error values. + do i = 1, npts { + call fprintf (fd, " %14.14s %14.7g %14.7g %14.7g %14.7g\n") + call pargstr (names[(i-1)*len_name+1]) + if (Mem$t[wts1+i-1] <= 0.0) { + call parg$t (INDEF) + call parg$t (INDEF) + call parg$t (INDEF) + call parg$t (INDEF) + } else { + call parg$t (y[i]) + call parg$t (Mem$t[fit+i-1]) + call parg$t (y[i] - Mem$t[fit+i-1]) + call parg$t (sqrt (PIXEL (1.0) / Mem$t[wts1+i-1])) + } + } + call fprintf (fd, "\n") + + # Free allocated memory, and close output file. + call sfree (sp) + call close (fd) +end diff --git a/pkg/xtools/inlfit/ingresultsd.x b/pkg/xtools/inlfit/ingresultsd.x new file mode 100644 index 00000000..c19d8166 --- /dev/null +++ b/pkg/xtools/inlfit/ingresultsd.x @@ -0,0 +1,85 @@ +include <pkg/inlfit.h> + +# ING_RESULTS -- Print the results of the fit. + +procedure ing_resultsd (in, file, nl, x, y, wts, names, npts, nvars, len_name) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +pointer nl # NLFIT pointer +double x[ARB] # Ordinates (npts * nvars) +double y[ARB] # Abscissas +double wts[ARB] # Weights +char names[ARB] # Object names +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of a name + +int i, fd, rejected +pointer sp, fit, wts1, rejpts +int open(), in_geti() +pointer in_getp() +errchk open + +begin + # Open the output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Test the number of points. + if (npts == 0) { + call eprintf ("Incomplete output - no data points for fit\n") + return + } + + # Allocate memory. + call smark (sp) + call salloc (fit, npts, TY_DOUBLE) + call salloc (wts1, npts, TY_DOUBLE) + + # Evaluate the fit. + call nlvectord (nl, x, Memd[fit], npts, nvars) + + # Assign a zero weight to the rejected points. + rejected = in_geti (in, INLNREJPTS) + rejpts = in_getp (in, INLREJPTS) + call amovd (wts, Memd[wts1], npts) + if (rejected > 0) { + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Memd[wts1+i-1] = double (0.0) + } + } + + # Print the title. + call fprintf (fd, "\n#%14.14s %14.14s %14.14s") + call pargstr ("objectid") + call pargstr ("function") + call pargstr ("fit") + call fprintf (fd, " %14.14s %14.14s\n") + call pargstr ("residuals") + call pargstr ("sigma") + + # List function value, fit value, residual and error values. + do i = 1, npts { + call fprintf (fd, " %14.14s %14.7g %14.7g %14.7g %14.7g\n") + call pargstr (names[(i-1)*len_name+1]) + if (Memd[wts1+i-1] <= 0.0) { + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (y[i]) + call pargd (Memd[fit+i-1]) + call pargd (y[i] - Memd[fit+i-1]) + call pargd (sqrt (double (1.0) / Memd[wts1+i-1])) + } + } + call fprintf (fd, "\n") + + # Free allocated memory, and close output file. + call sfree (sp) + call close (fd) +end diff --git a/pkg/xtools/inlfit/ingresultsr.x b/pkg/xtools/inlfit/ingresultsr.x new file mode 100644 index 00000000..d6e6f43c --- /dev/null +++ b/pkg/xtools/inlfit/ingresultsr.x @@ -0,0 +1,85 @@ +include <pkg/inlfit.h> + +# ING_RESULTS -- Print the results of the fit. + +procedure ing_resultsr (in, file, nl, x, y, wts, names, npts, nvars, len_name) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +pointer nl # NLFIT pointer +real x[ARB] # Ordinates (npts * nvars) +real y[ARB] # Abscissas +real wts[ARB] # Weights +char names[ARB] # Object names +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of a name + +int i, fd, rejected +pointer sp, fit, wts1, rejpts +int open(), in_geti() +pointer in_getp() +errchk open + +begin + # Open the output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Test the number of points. + if (npts == 0) { + call eprintf ("Incomplete output - no data points for fit\n") + return + } + + # Allocate memory. + call smark (sp) + call salloc (fit, npts, TY_REAL) + call salloc (wts1, npts, TY_REAL) + + # Evaluate the fit. + call nlvectorr (nl, x, Memr[fit], npts, nvars) + + # Assign a zero weight to the rejected points. + rejected = in_geti (in, INLNREJPTS) + rejpts = in_getp (in, INLREJPTS) + call amovr (wts, Memr[wts1], npts) + if (rejected > 0) { + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + Memr[wts1+i-1] = real (0.0) + } + } + + # Print the title. + call fprintf (fd, "\n#%14.14s %14.14s %14.14s") + call pargstr ("objectid") + call pargstr ("function") + call pargstr ("fit") + call fprintf (fd, " %14.14s %14.14s\n") + call pargstr ("residuals") + call pargstr ("sigma") + + # List function value, fit value, residual and error values. + do i = 1, npts { + call fprintf (fd, " %14.14s %14.7g %14.7g %14.7g %14.7g\n") + call pargstr (names[(i-1)*len_name+1]) + if (Memr[wts1+i-1] <= 0.0) { + call pargr (INDEFR) + call pargr (INDEFR) + call pargr (INDEFR) + call pargr (INDEFR) + } else { + call pargr (y[i]) + call pargr (Memr[fit+i-1]) + call pargr (y[i] - Memr[fit+i-1]) + call pargr (sqrt (real (1.0) / Memr[wts1+i-1])) + } + } + call fprintf (fd, "\n") + + # Free allocated memory, and close output file. + call sfree (sp) + call close (fd) +end diff --git a/pkg/xtools/inlfit/ingshow.gx b/pkg/xtools/inlfit/ingshow.gx new file mode 100644 index 00000000..28efcc6e --- /dev/null +++ b/pkg/xtools/inlfit/ingshow.gx @@ -0,0 +1,40 @@ +include <pkg/inlfit.h> + + +# ING_SHOW -- Show the values of all the user defined parameters that +# can be changed with colon commands. The output can be any file. + +procedure ing_show$t (in, file) + +pointer in # INLFIT pointer +char file[ARB] # Output file + +int fd +int open(), in_geti() +PIXEL in_get$t +errchk open() + +begin + # Open output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Print parameters. + call fprintf (fd, "low_reject %g\n") + call parg$t (in_get$t (in, INLLOW)) + call fprintf (fd, "high_reject %g\n") + call parg$t (in_get$t (in, INLHIGH)) + call fprintf (fd, "nreject %d\n") + call pargi (in_geti (in, INLNREJECT)) + call fprintf (fd, "grow %g\n") + call parg$t (in_get$t (in, INLGROW)) + call fprintf (fd, "tol %g\n") + call parg$t (in_get$t (in, INLTOLERANCE)) + call fprintf (fd, "maxiter %d\n") + call pargi (in_geti (in, INLMAXITER)) + call fprintf (fd, "\n") + + # Free memory and close file. + call close (fd) +end diff --git a/pkg/xtools/inlfit/ingshowd.x b/pkg/xtools/inlfit/ingshowd.x new file mode 100644 index 00000000..031ae3f3 --- /dev/null +++ b/pkg/xtools/inlfit/ingshowd.x @@ -0,0 +1,40 @@ +include <pkg/inlfit.h> + + +# ING_SHOW -- Show the values of all the user defined parameters that +# can be changed with colon commands. The output can be any file. + +procedure ing_showd (in, file) + +pointer in # INLFIT pointer +char file[ARB] # Output file + +int fd +int open(), in_geti() +double in_getd +errchk open() + +begin + # Open output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Print parameters. + call fprintf (fd, "low_reject %g\n") + call pargd (in_getd (in, INLLOW)) + call fprintf (fd, "high_reject %g\n") + call pargd (in_getd (in, INLHIGH)) + call fprintf (fd, "nreject %d\n") + call pargi (in_geti (in, INLNREJECT)) + call fprintf (fd, "grow %g\n") + call pargd (in_getd (in, INLGROW)) + call fprintf (fd, "tol %g\n") + call pargd (in_getd (in, INLTOLERANCE)) + call fprintf (fd, "maxiter %d\n") + call pargi (in_geti (in, INLMAXITER)) + call fprintf (fd, "\n") + + # Free memory and close file. + call close (fd) +end diff --git a/pkg/xtools/inlfit/ingshowr.x b/pkg/xtools/inlfit/ingshowr.x new file mode 100644 index 00000000..237c90df --- /dev/null +++ b/pkg/xtools/inlfit/ingshowr.x @@ -0,0 +1,40 @@ +include <pkg/inlfit.h> + + +# ING_SHOW -- Show the values of all the user defined parameters that +# can be changed with colon commands. The output can be any file. + +procedure ing_showr (in, file) + +pointer in # INLFIT pointer +char file[ARB] # Output file + +int fd +int open(), in_geti() +real in_getr +errchk open() + +begin + # Open output file. + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + # Print parameters. + call fprintf (fd, "low_reject %g\n") + call pargr (in_getr (in, INLLOW)) + call fprintf (fd, "high_reject %g\n") + call pargr (in_getr (in, INLHIGH)) + call fprintf (fd, "nreject %d\n") + call pargi (in_geti (in, INLNREJECT)) + call fprintf (fd, "grow %g\n") + call pargr (in_getr (in, INLGROW)) + call fprintf (fd, "tol %g\n") + call pargr (in_getr (in, INLTOLERANCE)) + call fprintf (fd, "maxiter %d\n") + call pargi (in_geti (in, INLMAXITER)) + call fprintf (fd, "\n") + + # Free memory and close file. + call close (fd) +end diff --git a/pkg/xtools/inlfit/ingtitle.x b/pkg/xtools/inlfit/ingtitle.x new file mode 100644 index 00000000..8b9fd877 --- /dev/null +++ b/pkg/xtools/inlfit/ingtitle.x @@ -0,0 +1,49 @@ +include <pkg/gtools.h> + +# ING_TITLE -- Write out the time stamp and the title of the current fit. + +procedure ing_title (in, file, gt) + +pointer in # pointer to the inlfit structure (not used yet) +char file[ARB] # arbitrary file name +pointer gt # pointer to the gtools structure + +int fd, sfd +pointer sp, str +int open(), stropen(), fscan() +long clktime() + +begin + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Put time stamp in. + call cnvtime (clktime(0), Memc[str], SZ_LINE) + call fprintf (fd, "\n#%s\n") + call pargstr (Memc[str]) + + # Print plot title. + call gt_gets (gt, GTTITLE, Memc[str], SZ_LINE) + sfd = stropen (Memc[str], SZ_LINE, READ_ONLY) + while (fscan (sfd) != EOF) { + call gargstr (Memc[str], SZ_LINE) + call fprintf (fd, "#%s\n") + call pargstr (Memc[str]) + } + call fprintf (fd, "\n") + call strclose (sfd) + + # Print fit units. + #call gt_gets (gt, GTYUNITS, Memc[str], SZ_LINE) + #if (Memc[str] != EOS) { + #call fprintf (fd, "fit_units %s\n") + #call pargstr (Memc[str]) + #} + + call sfree (sp) + call close (fd) +end diff --git a/pkg/xtools/inlfit/inguaxes.gx b/pkg/xtools/inlfit/inguaxes.gx new file mode 100644 index 00000000..58942f52 --- /dev/null +++ b/pkg/xtools/inlfit/inguaxes.gx @@ -0,0 +1,47 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# ING_UAXES -- Set user axis + +procedure ing_uaxes$t (keynum, in, nl, x, y, z, npts, nvars) + +int keynum # Key number for axes +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +PIXEL x[ARB] # Independent variable +PIXEL y[npts] # Dependent variable +PIXEL z[npts] # Output values +int npts # Number of points +int nvars # Number of variables + +int npars # number of parameters +int uaxes # user defined procedure +pointer params # parameter values +pointer sp + +int nlstati() +int in_geti() + +begin + # Check if equation is defined + uaxes = in_geti (in, INLUAXES) + if (!IS_INDEFI (uaxes)) { + + # Get number of parameters, allocate space + # for parameter values, and get parameter values + npars = nlstati (nl, NLNPARAMS) + call smark (sp) + call salloc (params, npars, TY_PIXEL) + call nlpget$t (nl, Mem$t[params], npars) + + # Call user plot functions + call zcall8 (uaxes, keynum, Mem$t[params], npars, + x, y, z, npts, nvars) + + # Free memory + call sfree (sp) + + } else + call eprintf ("Warning: User plot function not defined\n") +end diff --git a/pkg/xtools/inlfit/inguaxesd.x b/pkg/xtools/inlfit/inguaxesd.x new file mode 100644 index 00000000..48759bc0 --- /dev/null +++ b/pkg/xtools/inlfit/inguaxesd.x @@ -0,0 +1,47 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# ING_UAXES -- Set user axis + +procedure ing_uaxesd (keynum, in, nl, x, y, z, npts, nvars) + +int keynum # Key number for axes +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +double x[ARB] # Independent variable +double y[npts] # Dependent variable +double z[npts] # Output values +int npts # Number of points +int nvars # Number of variables + +int npars # number of parameters +int uaxes # user defined procedure +pointer params # parameter values +pointer sp + +int nlstati() +int in_geti() + +begin + # Check if equation is defined + uaxes = in_geti (in, INLUAXES) + if (!IS_INDEFI (uaxes)) { + + # Get number of parameters, allocate space + # for parameter values, and get parameter values + npars = nlstati (nl, NLNPARAMS) + call smark (sp) + call salloc (params, npars, TY_DOUBLE) + call nlpgetd (nl, Memd[params], npars) + + # Call user plot functions + call zcall8 (uaxes, keynum, Memd[params], npars, + x, y, z, npts, nvars) + + # Free memory + call sfree (sp) + + } else + call eprintf ("Warning: User plot function not defined\n") +end diff --git a/pkg/xtools/inlfit/inguaxesr.x b/pkg/xtools/inlfit/inguaxesr.x new file mode 100644 index 00000000..53905563 --- /dev/null +++ b/pkg/xtools/inlfit/inguaxesr.x @@ -0,0 +1,47 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# ING_UAXES -- Set user axis + +procedure ing_uaxesr (keynum, in, nl, x, y, z, npts, nvars) + +int keynum # Key number for axes +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +real x[ARB] # Independent variable +real y[npts] # Dependent variable +real z[npts] # Output values +int npts # Number of points +int nvars # Number of variables + +int npars # number of parameters +int uaxes # user defined procedure +pointer params # parameter values +pointer sp + +int nlstati() +int in_geti() + +begin + # Check if equation is defined + uaxes = in_geti (in, INLUAXES) + if (!IS_INDEFI (uaxes)) { + + # Get number of parameters, allocate space + # for parameter values, and get parameter values + npars = nlstati (nl, NLNPARAMS) + call smark (sp) + call salloc (params, npars, TY_REAL) + call nlpgetr (nl, Memr[params], npars) + + # Call user plot functions + call zcall8 (uaxes, keynum, Memr[params], npars, + x, y, z, npts, nvars) + + # Free memory + call sfree (sp) + + } else + call eprintf ("Warning: User plot function not defined\n") +end diff --git a/pkg/xtools/inlfit/ingucolon.gx b/pkg/xtools/inlfit/ingucolon.gx new file mode 100644 index 00000000..3e858789 --- /dev/null +++ b/pkg/xtools/inlfit/ingucolon.gx @@ -0,0 +1,19 @@ +# ING_UCOLON -- User default colon commands + +procedure ing_ucolon$t (in, gp, gt, nl, x, y, wts, npts, nvars, newgraph) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +PIXEL x[ARB] # Independent variables +PIXEL y[npts] # Dependent variables +PIXEL wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +int newgraph # New graph ? (output) + +begin + # Ring bell + call printf ("\07\n") +end diff --git a/pkg/xtools/inlfit/ingucolond.x b/pkg/xtools/inlfit/ingucolond.x new file mode 100644 index 00000000..db3ab047 --- /dev/null +++ b/pkg/xtools/inlfit/ingucolond.x @@ -0,0 +1,19 @@ +# ING_UCOLON -- User default colon commands + +procedure ing_ucolond (in, gp, gt, nl, x, y, wts, npts, nvars, newgraph) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +double x[ARB] # Independent variables +double y[npts] # Dependent variables +double wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +int newgraph # New graph ? (output) + +begin + # Ring bell + call printf ("\07\n") +end diff --git a/pkg/xtools/inlfit/ingucolonr.x b/pkg/xtools/inlfit/ingucolonr.x new file mode 100644 index 00000000..1a7de7a5 --- /dev/null +++ b/pkg/xtools/inlfit/ingucolonr.x @@ -0,0 +1,19 @@ +# ING_UCOLON -- User default colon commands + +procedure ing_ucolonr (in, gp, gt, nl, x, y, wts, npts, nvars, newgraph) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +real x[ARB] # Independent variables +real y[npts] # Dependent variables +real wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +int newgraph # New graph ? (output) + +begin + # Ring bell + call printf ("\07\n") +end diff --git a/pkg/xtools/inlfit/ingufit.x b/pkg/xtools/inlfit/ingufit.x new file mode 100644 index 00000000..5780d755 --- /dev/null +++ b/pkg/xtools/inlfit/ingufit.x @@ -0,0 +1,17 @@ +# ING_UFIT -- User default action for interactive fitting commands + +procedure ing_ufit (in, gp, gt, nl, wx, wy, wcs, key, cmd) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +real wx, wy # Cursor positions +int wcs # GIO WCS +int key # Cursor key +char cmd[ARB] # Cursor command + +begin + # Ring bell + call printf ("\07\n") +end diff --git a/pkg/xtools/inlfit/ingundelete.gx b/pkg/xtools/inlfit/ingundelete.gx new file mode 100644 index 00000000..4b59156f --- /dev/null +++ b/pkg/xtools/inlfit/ingundelete.gx @@ -0,0 +1,92 @@ +include <gset.h> +include <mach.h> +include <pkg/gtools.h> + +define MSIZE 2.0 # Mark size (real) + + +# ING_UNDELETE -- Undelete data point nearest the cursor. The nearest point to +# the cursor in NDC coordinates is determined. + +procedure ing_undelete$t (in, gp, gt, nl, x, y, wts, userwts, npts, nvars, + wx, wy) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +PIXEL x[ARB] # Independent variables (npts * nvars) +PIXEL y[npts] # Dependent variables +PIXEL wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +int nvars # Number of variables +real wx, wy # Position to be nearest + +pointer sp, xout, yout +int gt_geti() + +begin + # Allocate memory for the axes data. + call smark (sp) + call salloc (xout, npts, TY_PIXEL) + call salloc (yout, npts, TY_PIXEL) + + # Get the axes data. + call ing_axes$t (in, gt, nl, 1, x, y, Mem$t[xout], npts, nvars) + call ing_axes$t (in, gt, nl, 2, x, y, Mem$t[yout], npts, nvars) + + # Transpose axes if necessary. + if (gt_geti (gt, GTTRANSPOSE) == NO) + call ing_u1$t (in, gp, Mem$t[xout], Mem$t[yout], wts, userwts, + npts, wx, wy) + else + call ing_u1$t (in, gp, Mem$t[yout], Mem$t[xout], wts, userwts, + npts, wy, wx) + + # Free memory. + call sfree (sp) +end + + +# ING_U1 -- Do the actual undelete. + +procedure ing_u1$t (in, gp, x, y, wts, userwts, npts, wx, wy) + +pointer in # ICFIT pointer +pointer gp # GIO pointer +PIXEL x[npts], y[npts] # Data points +PIXEL wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with zero weight. + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] != PIXEL (0.0)) + next + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Unmark the deleted point and reset the weight. + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gseti (gp, G_PMLTYPE, GL_CLEAR) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + call gseti (gp, G_PMLTYPE, GL_SOLID) + #call gline (gp, real (x[j]), real (y[j]), real (x[j]), real (y[j])) + call gmark (gp, real (x[j]), real (y[j]), GM_PLUS, MSIZE, MSIZE) + wts[j] = userwts[j] + } +end diff --git a/pkg/xtools/inlfit/ingundeleted.x b/pkg/xtools/inlfit/ingundeleted.x new file mode 100644 index 00000000..5b7717d9 --- /dev/null +++ b/pkg/xtools/inlfit/ingundeleted.x @@ -0,0 +1,92 @@ +include <gset.h> +include <mach.h> +include <pkg/gtools.h> + +define MSIZE 2.0 # Mark size (real) + + +# ING_UNDELETE -- Undelete data point nearest the cursor. The nearest point to +# the cursor in NDC coordinates is determined. + +procedure ing_undeleted (in, gp, gt, nl, x, y, wts, userwts, npts, nvars, + wx, wy) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +double x[ARB] # Independent variables (npts * nvars) +double y[npts] # Dependent variables +double wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +int nvars # Number of variables +real wx, wy # Position to be nearest + +pointer sp, xout, yout +int gt_geti() + +begin + # Allocate memory for the axes data. + call smark (sp) + call salloc (xout, npts, TY_DOUBLE) + call salloc (yout, npts, TY_DOUBLE) + + # Get the axes data. + call ing_axesd (in, gt, nl, 1, x, y, Memd[xout], npts, nvars) + call ing_axesd (in, gt, nl, 2, x, y, Memd[yout], npts, nvars) + + # Transpose axes if necessary. + if (gt_geti (gt, GTTRANSPOSE) == NO) + call ing_u1d (in, gp, Memd[xout], Memd[yout], wts, userwts, + npts, wx, wy) + else + call ing_u1d (in, gp, Memd[yout], Memd[xout], wts, userwts, + npts, wy, wx) + + # Free memory. + call sfree (sp) +end + + +# ING_U1 -- Do the actual undelete. + +procedure ing_u1d (in, gp, x, y, wts, userwts, npts, wx, wy) + +pointer in # ICFIT pointer +pointer gp # GIO pointer +double x[npts], y[npts] # Data points +double wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with zero weight. + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] != double (0.0)) + next + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Unmark the deleted point and reset the weight. + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gseti (gp, G_PMLTYPE, GL_CLEAR) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + call gseti (gp, G_PMLTYPE, GL_SOLID) + #call gline (gp, real (x[j]), real (y[j]), real (x[j]), real (y[j])) + call gmark (gp, real (x[j]), real (y[j]), GM_PLUS, MSIZE, MSIZE) + wts[j] = userwts[j] + } +end diff --git a/pkg/xtools/inlfit/ingundeleter.x b/pkg/xtools/inlfit/ingundeleter.x new file mode 100644 index 00000000..149003e5 --- /dev/null +++ b/pkg/xtools/inlfit/ingundeleter.x @@ -0,0 +1,92 @@ +include <gset.h> +include <mach.h> +include <pkg/gtools.h> + +define MSIZE 2.0 # Mark size (real) + + +# ING_UNDELETE -- Undelete data point nearest the cursor. The nearest point to +# the cursor in NDC coordinates is determined. + +procedure ing_undeleter (in, gp, gt, nl, x, y, wts, userwts, npts, nvars, + wx, wy) + +pointer in # INLFIT pointer +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer nl # NLFIT pointer +real x[ARB] # Independent variables (npts * nvars) +real y[npts] # Dependent variables +real wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +int nvars # Number of variables +real wx, wy # Position to be nearest + +pointer sp, xout, yout +int gt_geti() + +begin + # Allocate memory for the axes data. + call smark (sp) + call salloc (xout, npts, TY_REAL) + call salloc (yout, npts, TY_REAL) + + # Get the axes data. + call ing_axesr (in, gt, nl, 1, x, y, Memr[xout], npts, nvars) + call ing_axesr (in, gt, nl, 2, x, y, Memr[yout], npts, nvars) + + # Transpose axes if necessary. + if (gt_geti (gt, GTTRANSPOSE) == NO) + call ing_u1r (in, gp, Memr[xout], Memr[yout], wts, userwts, + npts, wx, wy) + else + call ing_u1r (in, gp, Memr[yout], Memr[xout], wts, userwts, + npts, wy, wx) + + # Free memory. + call sfree (sp) +end + + +# ING_U1 -- Do the actual undelete. + +procedure ing_u1r (in, gp, x, y, wts, userwts, npts, wx, wy) + +pointer in # ICFIT pointer +pointer gp # GIO pointer +real x[npts], y[npts] # Data points +real wts[npts], userwts[npts] # Weight arrays +int npts # Number of points +real wx, wy # Position to be nearest + +int i, j +real x0, y0, r2, r2min + +begin + # Transform world cursor coordinates to NDC. + call gctran (gp, wx, wy, wx, wy, 1, 0) + + # Search for nearest point to a point with zero weight. + r2min = MAX_REAL + do i = 1, npts { + if (wts[i] != real (0.0)) + next + call gctran (gp, real (x[i]), real (y[i]), x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Unmark the deleted point and reset the weight. + if (j != 0) { + call gscur (gp, real (x[j]), real (y[j])) + call gseti (gp, G_PMLTYPE, GL_CLEAR) + call gmark (gp, real (x[j]), real (y[j]), GM_CROSS, MSIZE, MSIZE) + call gseti (gp, G_PMLTYPE, GL_SOLID) + #call gline (gp, real (x[j]), real (y[j]), real (x[j]), real (y[j])) + call gmark (gp, real (x[j]), real (y[j]), GM_PLUS, MSIZE, MSIZE) + wts[j] = userwts[j] + } +end diff --git a/pkg/xtools/inlfit/ingvars.gx b/pkg/xtools/inlfit/ingvars.gx new file mode 100644 index 00000000..291284a0 --- /dev/null +++ b/pkg/xtools/inlfit/ingvars.gx @@ -0,0 +1,55 @@ +include <pkg/inlfit.h> + +# ING_VARIABLES -- Write the variable numbers, names and minimum and maximum +# values to a file. + +procedure ing_variables$t (in, file, nvars) + +pointer in # pointer to the inlfit structure +char file[ARB] # output file name +int nvars # number of variables + +int i, fd +pointer sp, labels, pvnames, name, minptr, maxptr +int open(), inlstrwrd() +pointer in_getp() + +begin + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + call smark (sp) + call salloc (labels, SZ_LINE, TY_CHAR) + call salloc (pvnames, SZ_LINE, TY_CHAR) + call salloc (name, SZ_LINE, TY_CHAR) + call in_gstr (in, INLVLABELS, Memc[labels], SZ_LINE) + call strcpy (Memc[labels], Memc[pvnames], SZ_LINE) + + # Print the title string. + call fprintf (fd, "\n%-10.10s %-10.10s %14.14s %14.14s\n") + call pargstr ("number") + call pargstr ("variable") + call pargstr ("minimum") + call pargstr ("maximum") + + # Print the variables. + minptr = in_getp (in, INLXMIN) + maxptr = in_getp (in, INLXMAX) + do i = 1, nvars { + if (inlstrwrd (i, Memc[name], SZ_LINE, Memc[pvnames]) == 0) { + call sprintf (Memc[name], SZ_LINE, "var %d") + call pargi (i) + } + call fprintf (fd, "%-10.2d %-10.10s ") + call pargi (i) + call pargstr (Memc[name]) + call fprintf (fd, "%14.7f %14.7f\n") + call parg$t (Mem$t[minptr+i-1]) + call parg$t (Mem$t[maxptr+i-1]) + } + call fprintf (fd, "\n") + + call close (fd) + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingvarsd.x b/pkg/xtools/inlfit/ingvarsd.x new file mode 100644 index 00000000..257b51fb --- /dev/null +++ b/pkg/xtools/inlfit/ingvarsd.x @@ -0,0 +1,55 @@ +include <pkg/inlfit.h> + +# ING_VARIABLES -- Write the variable numbers, names and minimum and maximum +# values to a file. + +procedure ing_variablesd (in, file, nvars) + +pointer in # pointer to the inlfit structure +char file[ARB] # output file name +int nvars # number of variables + +int i, fd +pointer sp, labels, pvnames, name, minptr, maxptr +int open(), inlstrwrd() +pointer in_getp() + +begin + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + call smark (sp) + call salloc (labels, SZ_LINE, TY_CHAR) + call salloc (pvnames, SZ_LINE, TY_CHAR) + call salloc (name, SZ_LINE, TY_CHAR) + call in_gstr (in, INLVLABELS, Memc[labels], SZ_LINE) + call strcpy (Memc[labels], Memc[pvnames], SZ_LINE) + + # Print the title string. + call fprintf (fd, "\n%-10.10s %-10.10s %14.14s %14.14s\n") + call pargstr ("number") + call pargstr ("variable") + call pargstr ("minimum") + call pargstr ("maximum") + + # Print the variables. + minptr = in_getp (in, INLXMIN) + maxptr = in_getp (in, INLXMAX) + do i = 1, nvars { + if (inlstrwrd (i, Memc[name], SZ_LINE, Memc[pvnames]) == 0) { + call sprintf (Memc[name], SZ_LINE, "var %d") + call pargi (i) + } + call fprintf (fd, "%-10.2d %-10.10s ") + call pargi (i) + call pargstr (Memc[name]) + call fprintf (fd, "%14.7f %14.7f\n") + call pargd (Memd[minptr+i-1]) + call pargd (Memd[maxptr+i-1]) + } + call fprintf (fd, "\n") + + call close (fd) + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingvarsr.x b/pkg/xtools/inlfit/ingvarsr.x new file mode 100644 index 00000000..b0855805 --- /dev/null +++ b/pkg/xtools/inlfit/ingvarsr.x @@ -0,0 +1,55 @@ +include <pkg/inlfit.h> + +# ING_VARIABLES -- Write the variable numbers, names and minimum and maximum +# values to a file. + +procedure ing_variablesr (in, file, nvars) + +pointer in # pointer to the inlfit structure +char file[ARB] # output file name +int nvars # number of variables + +int i, fd +pointer sp, labels, pvnames, name, minptr, maxptr +int open(), inlstrwrd() +pointer in_getp() + +begin + if (file[1] == EOS) + return + fd = open (file, APPEND, TEXT_FILE) + + call smark (sp) + call salloc (labels, SZ_LINE, TY_CHAR) + call salloc (pvnames, SZ_LINE, TY_CHAR) + call salloc (name, SZ_LINE, TY_CHAR) + call in_gstr (in, INLVLABELS, Memc[labels], SZ_LINE) + call strcpy (Memc[labels], Memc[pvnames], SZ_LINE) + + # Print the title string. + call fprintf (fd, "\n%-10.10s %-10.10s %14.14s %14.14s\n") + call pargstr ("number") + call pargstr ("variable") + call pargstr ("minimum") + call pargstr ("maximum") + + # Print the variables. + minptr = in_getp (in, INLXMIN) + maxptr = in_getp (in, INLXMAX) + do i = 1, nvars { + if (inlstrwrd (i, Memc[name], SZ_LINE, Memc[pvnames]) == 0) { + call sprintf (Memc[name], SZ_LINE, "var %d") + call pargi (i) + } + call fprintf (fd, "%-10.2d %-10.10s ") + call pargi (i) + call pargstr (Memc[name]) + call fprintf (fd, "%14.7f %14.7f\n") + call pargr (Memr[minptr+i-1]) + call pargr (Memr[maxptr+i-1]) + } + call fprintf (fd, "\n") + + call close (fd) + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/ingvshow.gx b/pkg/xtools/inlfit/ingvshow.gx new file mode 100644 index 00000000..129e6b4c --- /dev/null +++ b/pkg/xtools/inlfit/ingvshow.gx @@ -0,0 +1,34 @@ +include <pkg/inlfit.h> + + +# ING_VSHOW -- Show fit parameters in verbose mode on the screen. + +procedure ing_vshow$t (in, file, nl, x, y, wts, names, npts, nvars, len_name, + gt) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +pointer nl # NLFIT pointer +PIXEL x[ARB] # Ordinates (npts * nvars) +PIXEL y[ARB] # Abscissas +PIXEL wts[ARB] # Weights +char names[ARB] # Object ids +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of id name +pointer gt # Graphics tools pointer + +begin + # Print the title. + call ing_title (in, file, gt) + + # Do the standard ing_show option. + call ing_show$t (in, file) + + # Print the error analysis information. + call ing_errors$t (in, file, nl, x, y, wts, npts, nvars) + + # Print the results. + call ing_results$t (in, file, nl, x, y, wts, names, npts, nvars, + len_name) +end diff --git a/pkg/xtools/inlfit/ingvshowd.x b/pkg/xtools/inlfit/ingvshowd.x new file mode 100644 index 00000000..e7a2af30 --- /dev/null +++ b/pkg/xtools/inlfit/ingvshowd.x @@ -0,0 +1,34 @@ +include <pkg/inlfit.h> + + +# ING_VSHOW -- Show fit parameters in verbose mode on the screen. + +procedure ing_vshowd (in, file, nl, x, y, wts, names, npts, nvars, len_name, + gt) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +pointer nl # NLFIT pointer +double x[ARB] # Ordinates (npts * nvars) +double y[ARB] # Abscissas +double wts[ARB] # Weights +char names[ARB] # Object ids +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of id name +pointer gt # Graphics tools pointer + +begin + # Print the title. + call ing_title (in, file, gt) + + # Do the standard ing_show option. + call ing_showd (in, file) + + # Print the error analysis information. + call ing_errorsd (in, file, nl, x, y, wts, npts, nvars) + + # Print the results. + call ing_resultsd (in, file, nl, x, y, wts, names, npts, nvars, + len_name) +end diff --git a/pkg/xtools/inlfit/ingvshowr.x b/pkg/xtools/inlfit/ingvshowr.x new file mode 100644 index 00000000..aed987ce --- /dev/null +++ b/pkg/xtools/inlfit/ingvshowr.x @@ -0,0 +1,34 @@ +include <pkg/inlfit.h> + + +# ING_VSHOW -- Show fit parameters in verbose mode on the screen. + +procedure ing_vshowr (in, file, nl, x, y, wts, names, npts, nvars, len_name, + gt) + +pointer in # INLFIT pointer +char file[ARB] # Output file name +pointer nl # NLFIT pointer +real x[ARB] # Ordinates (npts * nvars) +real y[ARB] # Abscissas +real wts[ARB] # Weights +char names[ARB] # Object ids +int npts # Number of data points +int nvars # Number of variables +int len_name # Length of id name +pointer gt # Graphics tools pointer + +begin + # Print the title. + call ing_title (in, file, gt) + + # Do the standard ing_show option. + call ing_showr (in, file) + + # Print the error analysis information. + call ing_errorsr (in, file, nl, x, y, wts, npts, nvars) + + # Print the results. + call ing_resultsr (in, file, nl, x, y, wts, names, npts, nvars, + len_name) +end diff --git a/pkg/xtools/inlfit/ininit.gx b/pkg/xtools/inlfit/ininit.gx new file mode 100644 index 00000000..a0df0ffe --- /dev/null +++ b/pkg/xtools/inlfit/ininit.gx @@ -0,0 +1,172 @@ +.help ininit +INLFIT memory allocation procedures. All the calls to malloc() and realloc() +are grouped in this file. Acces to the INLFIT structure is restricted to +the in_get() and in_put() procedures, except for buffer allocation and +initialization. +.nf + +User entry points: + + in_init$t (in, func, dfunc, param, dparam, nparams, plist, nfparams) + +Low level entry point: + + in_bfinit$t (in, npts, nvars) +.fi +.endhelp + +include <pkg/inlfit.h> +include "inlfitdef.h" + + +# IN_INIT -- Initialize INLFIT parameter structure. + +procedure in_init$t (in, func, dfunc, param, dparam, nparams, plist, nfparams) + +pointer in # INLFIT pointer +int func # fitting function address +int dfunc # derivative function address +PIXEL param[nparams] # parameter values +PIXEL dparam[nparams] # initial guess at uncertenties in parameters +int nparams # number of parameters +int plist[nparams] # list of active parameters +int nfparams # number of fitting paramters + +begin +# # Debug. +# call eprintf ( +# "in_init: in=%d, func=%d, dfunc=%d, npars=%d, nfpars=%d\n") +# call pargi (in) +# call pargi (func) +# call pargi (dfunc) +# call pargi (nparams) +# call pargi (nfparams) + + # Allocate the structure memory. + call malloc (in, LEN_INLSTRUCT, TY_STRUCT) + + # Allocate memory for parameter values, changes, and list. + call malloc (IN_PARAM (in), nparams, TY_PIXEL) + call malloc (IN_DPARAM (in), nparams, TY_PIXEL) + call malloc (IN_PLIST (in), nparams, TY_INT) + + # Allocate space for strings. All strings are limited + # to SZ_LINE or SZ_FNAME. + call malloc (IN_LABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_UNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_FLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_FUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_PLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_PUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_VLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_VUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_USERLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_USERUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_HELP(in), SZ_FNAME, TY_CHAR) + call malloc (IN_PROMPT(in), SZ_FNAME, TY_CHAR) + + # Allocate space for floating point and graph substructures. + call malloc (IN_SFLOAT (in), LEN_INLFLOAT, TY_PIXEL) + call malloc (IN_SGAXES (in), INLNGKEYS * LEN_INLGRAPH, TY_INT) + + # Enter procedure parameters into the structure. + call in_puti (in, INLFUNCTION, func) + call in_puti (in, INLDERIVATIVE, dfunc) + call in_puti (in, INLNPARAMS, nparams) + call in_puti (in, INLNFPARAMS, nfparams) + call amov$t (param, Mem$t[IN_PARAM(in)], nparams) + call amov$t (dparam, Mem$t[IN_DPARAM(in)], nparams) + call amovi (plist, Memi[IN_PLIST(in)], nparams) + + # Set defaults, just in case. + call in_put$t (in, INLTOLERANCE, PIXEL (0.01)) + call in_puti (in, INLMAXITER, 3) + call in_puti (in, INLNREJECT, 0) + call in_put$t (in, INLLOW, PIXEL (3.0)) + call in_put$t (in, INLHIGH, PIXEL (3.0)) + call in_put$t (in, INLGROW, PIXEL (0.0)) + + # Initialize the character strings. + call in_pstr (in, INLLABELS, KEY_TYPES) + call in_pstr (in, INLUNITS, "") + call in_pstr (in, INLFLABELS, "") + call in_pstr (in, INLFUNITS, "") + call in_pstr (in, INLPLABELS, "") + call in_pstr (in, INLPUNITS, "") + call in_pstr (in, INLVLABELS, "") + call in_pstr (in, INLVUNITS, "") + call in_pstr (in, INLUSERLABELS, "") + call in_pstr (in, INLUSERUNITS, "") + call in_pstr (in, INLHELP, IN_DEFHELP) + call in_pstr (in, INLPROMPT, IN_DEFPROMPT) + + # Initialize user defined functions. + call in_puti (in, INLUAXES, INDEFI) + call in_puti (in, INLUCOLON, INDEFI) + call in_puti (in, INLUFIT, INDEFI) + + # Initialize graph key, and axes. + call in_puti (in, INLGKEY, 2) + call in_pkey (in, 1, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 1, INLYAXIS, KEY_FIT, INDEFI) + call in_pkey (in, 2, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 2, INLYAXIS, KEY_RESIDUALS, INDEFI) + call in_pkey (in, 3, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 3, INLYAXIS, KEY_RATIO, INDEFI) + call in_pkey (in, 4, INLXAXIS, KEY_VARIABLE, 1) + call in_pkey (in, 4, INLYAXIS, KEY_RESIDUALS, INDEFI) + call in_pkey (in, 5, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 5, INLYAXIS, KEY_RESIDUALS, INDEFI) + + # Initialize flags and counters. + call in_puti (in, INLOVERPLOT, NO) + call in_puti (in, INLPLOTFIT, NO) + call in_puti (in, INLNREJPTS, 0) + call in_puti (in, INLNVARS, 0) + call in_puti (in, INLNPTS, 0) + + # Initialize pointers. + call in_putp (in, INLREJPTS, NULL) + call in_putp (in, INLXMIN, NULL) + call in_putp (in, INLXMAX, NULL) +end + + +# IN_BFINIT -- Initialize the rejected point counter, number of variables, +# rejected point list, and the buffers containing the minimum and maximum +# variable values. The rejected point list and limit value buffers are +# reallocated, if necessary. + +procedure in_bfinit$t (in, npts, nvars) + +pointer in # INLFIT descriptor +int npts # number of points +int nvars # number of variables + +int in_geti() + +begin +# # Debug. +# call eprintf ("in_bfinit: in=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (npts) +# call pargi (nvars) + + # Clear rejected point counter, and initialize number of variables. + call in_puti (in, INLNREJPTS, 0) + + # Reallocate space for rejected point list and initialize it. + if (in_geti (in, INLNPTS) != npts) { + call in_puti (in, INLNPTS, npts) + call realloc (IN_REJPTS (in), npts, TY_INT) + } + call amovki (NO, Memi[IN_REJPTS(in)], npts) + + # Reallocate space for minimum and maximum variable values. + # Initialization is made afterwards. + if (in_geti (in, INLNVARS) != nvars) { + call in_puti (in, INLNVARS, nvars) + call realloc (IN_XMIN (in), nvars, TY_PIXEL) + call realloc (IN_XMAX (in), nvars, TY_PIXEL) + } +end diff --git a/pkg/xtools/inlfit/ininitd.x b/pkg/xtools/inlfit/ininitd.x new file mode 100644 index 00000000..147f2886 --- /dev/null +++ b/pkg/xtools/inlfit/ininitd.x @@ -0,0 +1,172 @@ +.help ininit +INLFIT memory allocation procedures. All the calls to malloc() and realloc() +are grouped in this file. Acces to the INLFIT structure is restricted to +the in_get() and in_put() procedures, except for buffer allocation and +initialization. +.nf + +User entry points: + + in_initd (in, func, dfunc, param, dparam, nparams, plist, nfparams) + +Low level entry point: + + in_bfinitd (in, npts, nvars) +.fi +.endhelp + +include <pkg/inlfit.h> +include "inlfitdef.h" + + +# IN_INIT -- Initialize INLFIT parameter structure. + +procedure in_initd (in, func, dfunc, param, dparam, nparams, plist, nfparams) + +pointer in # INLFIT pointer +int func # fitting function address +int dfunc # derivative function address +double param[nparams] # parameter values +double dparam[nparams] # initial guess at uncertenties in parameters +int nparams # number of parameters +int plist[nparams] # list of active parameters +int nfparams # number of fitting paramters + +begin +# # Debug. +# call eprintf ( +# "in_init: in=%d, func=%d, dfunc=%d, npars=%d, nfpars=%d\n") +# call pargi (in) +# call pargi (func) +# call pargi (dfunc) +# call pargi (nparams) +# call pargi (nfparams) + + # Allocate the structure memory. + call malloc (in, LEN_INLSTRUCT, TY_STRUCT) + + # Allocate memory for parameter values, changes, and list. + call malloc (IN_PARAM (in), nparams, TY_DOUBLE) + call malloc (IN_DPARAM (in), nparams, TY_DOUBLE) + call malloc (IN_PLIST (in), nparams, TY_INT) + + # Allocate space for strings. All strings are limited + # to SZ_LINE or SZ_FNAME. + call malloc (IN_LABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_UNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_FLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_FUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_PLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_PUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_VLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_VUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_USERLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_USERUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_HELP(in), SZ_FNAME, TY_CHAR) + call malloc (IN_PROMPT(in), SZ_FNAME, TY_CHAR) + + # Allocate space for floating point and graph substructures. + call malloc (IN_SFLOAT (in), LEN_INLFLOAT, TY_DOUBLE) + call malloc (IN_SGAXES (in), INLNGKEYS * LEN_INLGRAPH, TY_INT) + + # Enter procedure parameters into the structure. + call in_puti (in, INLFUNCTION, func) + call in_puti (in, INLDERIVATIVE, dfunc) + call in_puti (in, INLNPARAMS, nparams) + call in_puti (in, INLNFPARAMS, nfparams) + call amovd (param, Memd[IN_PARAM(in)], nparams) + call amovd (dparam, Memd[IN_DPARAM(in)], nparams) + call amovi (plist, Memi[IN_PLIST(in)], nparams) + + # Set defaults, just in case. + call in_putd (in, INLTOLERANCE, double (0.01)) + call in_puti (in, INLMAXITER, 3) + call in_puti (in, INLNREJECT, 0) + call in_putd (in, INLLOW, double (3.0)) + call in_putd (in, INLHIGH, double (3.0)) + call in_putd (in, INLGROW, double (0.0)) + + # Initialize the character strings. + call in_pstr (in, INLLABELS, KEY_TYPES) + call in_pstr (in, INLUNITS, "") + call in_pstr (in, INLFLABELS, "") + call in_pstr (in, INLFUNITS, "") + call in_pstr (in, INLPLABELS, "") + call in_pstr (in, INLPUNITS, "") + call in_pstr (in, INLVLABELS, "") + call in_pstr (in, INLVUNITS, "") + call in_pstr (in, INLUSERLABELS, "") + call in_pstr (in, INLUSERUNITS, "") + call in_pstr (in, INLHELP, IN_DEFHELP) + call in_pstr (in, INLPROMPT, IN_DEFPROMPT) + + # Initialize user defined functions. + call in_puti (in, INLUAXES, INDEFI) + call in_puti (in, INLUCOLON, INDEFI) + call in_puti (in, INLUFIT, INDEFI) + + # Initialize graph key, and axes. + call in_puti (in, INLGKEY, 2) + call in_pkey (in, 1, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 1, INLYAXIS, KEY_FIT, INDEFI) + call in_pkey (in, 2, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 2, INLYAXIS, KEY_RESIDUALS, INDEFI) + call in_pkey (in, 3, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 3, INLYAXIS, KEY_RATIO, INDEFI) + call in_pkey (in, 4, INLXAXIS, KEY_VARIABLE, 1) + call in_pkey (in, 4, INLYAXIS, KEY_RESIDUALS, INDEFI) + call in_pkey (in, 5, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 5, INLYAXIS, KEY_RESIDUALS, INDEFI) + + # Initialize flags and counters. + call in_puti (in, INLOVERPLOT, NO) + call in_puti (in, INLPLOTFIT, NO) + call in_puti (in, INLNREJPTS, 0) + call in_puti (in, INLNVARS, 0) + call in_puti (in, INLNPTS, 0) + + # Initialize pointers. + call in_putp (in, INLREJPTS, NULL) + call in_putp (in, INLXMIN, NULL) + call in_putp (in, INLXMAX, NULL) +end + + +# IN_BFINIT -- Initialize the rejected point counter, number of variables, +# rejected point list, and the buffers containing the minimum and maximum +# variable values. The rejected point list and limit value buffers are +# reallocated, if necessary. + +procedure in_bfinitd (in, npts, nvars) + +pointer in # INLFIT descriptor +int npts # number of points +int nvars # number of variables + +int in_geti() + +begin +# # Debug. +# call eprintf ("in_bfinit: in=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (npts) +# call pargi (nvars) + + # Clear rejected point counter, and initialize number of variables. + call in_puti (in, INLNREJPTS, 0) + + # Reallocate space for rejected point list and initialize it. + if (in_geti (in, INLNPTS) != npts) { + call in_puti (in, INLNPTS, npts) + call realloc (IN_REJPTS (in), npts, TY_INT) + } + call amovki (NO, Memi[IN_REJPTS(in)], npts) + + # Reallocate space for minimum and maximum variable values. + # Initialization is made afterwards. + if (in_geti (in, INLNVARS) != nvars) { + call in_puti (in, INLNVARS, nvars) + call realloc (IN_XMIN (in), nvars, TY_DOUBLE) + call realloc (IN_XMAX (in), nvars, TY_DOUBLE) + } +end diff --git a/pkg/xtools/inlfit/ininitr.x b/pkg/xtools/inlfit/ininitr.x new file mode 100644 index 00000000..8c0f3469 --- /dev/null +++ b/pkg/xtools/inlfit/ininitr.x @@ -0,0 +1,172 @@ +.help ininit +INLFIT memory allocation procedures. All the calls to malloc() and realloc() +are grouped in this file. Acces to the INLFIT structure is restricted to +the in_get() and in_put() procedures, except for buffer allocation and +initialization. +.nf + +User entry points: + + in_initr (in, func, dfunc, param, dparam, nparams, plist, nfparams) + +Low level entry point: + + in_bfinitr (in, npts, nvars) +.fi +.endhelp + +include <pkg/inlfit.h> +include "inlfitdef.h" + + +# IN_INIT -- Initialize INLFIT parameter structure. + +procedure in_initr (in, func, dfunc, param, dparam, nparams, plist, nfparams) + +pointer in # INLFIT pointer +int func # fitting function address +int dfunc # derivative function address +real param[nparams] # parameter values +real dparam[nparams] # initial guess at uncertenties in parameters +int nparams # number of parameters +int plist[nparams] # list of active parameters +int nfparams # number of fitting paramters + +begin +# # Debug. +# call eprintf ( +# "in_init: in=%d, func=%d, dfunc=%d, npars=%d, nfpars=%d\n") +# call pargi (in) +# call pargi (func) +# call pargi (dfunc) +# call pargi (nparams) +# call pargi (nfparams) + + # Allocate the structure memory. + call malloc (in, LEN_INLSTRUCT, TY_STRUCT) + + # Allocate memory for parameter values, changes, and list. + call malloc (IN_PARAM (in), nparams, TY_REAL) + call malloc (IN_DPARAM (in), nparams, TY_REAL) + call malloc (IN_PLIST (in), nparams, TY_INT) + + # Allocate space for strings. All strings are limited + # to SZ_LINE or SZ_FNAME. + call malloc (IN_LABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_UNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_FLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_FUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_PLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_PUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_VLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_VUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_USERLABELS(in), SZ_LINE, TY_CHAR) + call malloc (IN_USERUNITS(in), SZ_LINE, TY_CHAR) + call malloc (IN_HELP(in), SZ_FNAME, TY_CHAR) + call malloc (IN_PROMPT(in), SZ_FNAME, TY_CHAR) + + # Allocate space for floating point and graph substructures. + call malloc (IN_SFLOAT (in), LEN_INLFLOAT, TY_REAL) + call malloc (IN_SGAXES (in), INLNGKEYS * LEN_INLGRAPH, TY_INT) + + # Enter procedure parameters into the structure. + call in_puti (in, INLFUNCTION, func) + call in_puti (in, INLDERIVATIVE, dfunc) + call in_puti (in, INLNPARAMS, nparams) + call in_puti (in, INLNFPARAMS, nfparams) + call amovr (param, Memr[IN_PARAM(in)], nparams) + call amovr (dparam, Memr[IN_DPARAM(in)], nparams) + call amovi (plist, Memi[IN_PLIST(in)], nparams) + + # Set defaults, just in case. + call in_putr (in, INLTOLERANCE, real (0.01)) + call in_puti (in, INLMAXITER, 3) + call in_puti (in, INLNREJECT, 0) + call in_putr (in, INLLOW, real (3.0)) + call in_putr (in, INLHIGH, real (3.0)) + call in_putr (in, INLGROW, real (0.0)) + + # Initialize the character strings. + call in_pstr (in, INLLABELS, KEY_TYPES) + call in_pstr (in, INLUNITS, "") + call in_pstr (in, INLFLABELS, "") + call in_pstr (in, INLFUNITS, "") + call in_pstr (in, INLPLABELS, "") + call in_pstr (in, INLPUNITS, "") + call in_pstr (in, INLVLABELS, "") + call in_pstr (in, INLVUNITS, "") + call in_pstr (in, INLUSERLABELS, "") + call in_pstr (in, INLUSERUNITS, "") + call in_pstr (in, INLHELP, IN_DEFHELP) + call in_pstr (in, INLPROMPT, IN_DEFPROMPT) + + # Initialize user defined functions. + call in_puti (in, INLUAXES, INDEFI) + call in_puti (in, INLUCOLON, INDEFI) + call in_puti (in, INLUFIT, INDEFI) + + # Initialize graph key, and axes. + call in_puti (in, INLGKEY, 2) + call in_pkey (in, 1, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 1, INLYAXIS, KEY_FIT, INDEFI) + call in_pkey (in, 2, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 2, INLYAXIS, KEY_RESIDUALS, INDEFI) + call in_pkey (in, 3, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 3, INLYAXIS, KEY_RATIO, INDEFI) + call in_pkey (in, 4, INLXAXIS, KEY_VARIABLE, 1) + call in_pkey (in, 4, INLYAXIS, KEY_RESIDUALS, INDEFI) + call in_pkey (in, 5, INLXAXIS, KEY_FUNCTION, INDEFI) + call in_pkey (in, 5, INLYAXIS, KEY_RESIDUALS, INDEFI) + + # Initialize flags and counters. + call in_puti (in, INLOVERPLOT, NO) + call in_puti (in, INLPLOTFIT, NO) + call in_puti (in, INLNREJPTS, 0) + call in_puti (in, INLNVARS, 0) + call in_puti (in, INLNPTS, 0) + + # Initialize pointers. + call in_putp (in, INLREJPTS, NULL) + call in_putp (in, INLXMIN, NULL) + call in_putp (in, INLXMAX, NULL) +end + + +# IN_BFINIT -- Initialize the rejected point counter, number of variables, +# rejected point list, and the buffers containing the minimum and maximum +# variable values. The rejected point list and limit value buffers are +# reallocated, if necessary. + +procedure in_bfinitr (in, npts, nvars) + +pointer in # INLFIT descriptor +int npts # number of points +int nvars # number of variables + +int in_geti() + +begin +# # Debug. +# call eprintf ("in_bfinit: in=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (npts) +# call pargi (nvars) + + # Clear rejected point counter, and initialize number of variables. + call in_puti (in, INLNREJPTS, 0) + + # Reallocate space for rejected point list and initialize it. + if (in_geti (in, INLNPTS) != npts) { + call in_puti (in, INLNPTS, npts) + call realloc (IN_REJPTS (in), npts, TY_INT) + } + call amovki (NO, Memi[IN_REJPTS(in)], npts) + + # Reallocate space for minimum and maximum variable values. + # Initialization is made afterwards. + if (in_geti (in, INLNVARS) != nvars) { + call in_puti (in, INLNVARS, nvars) + call realloc (IN_XMIN (in), nvars, TY_REAL) + call realloc (IN_XMAX (in), nvars, TY_REAL) + } +end diff --git a/pkg/xtools/inlfit/inlfitdef.h b/pkg/xtools/inlfit/inlfitdef.h new file mode 100644 index 00000000..0153f20f --- /dev/null +++ b/pkg/xtools/inlfit/inlfitdef.h @@ -0,0 +1,148 @@ +# The INLFIT data structure and private definitions. + +# Pointer Mem + +define MEMP Memi + + +# Default help file and prompt + +define IN_DEFHELP "lib$scr/inlgfit.key" +define IN_DEFPROMPT "inlfit cursor options" + + +# Graphic key/axis types +define KEY_TYPES "|function|fit|residuals|ratio|nonlinear|var|user|" + + +# ---------------------------------------------------------------------- +# INLFIT structure definition. + +# Structure length. +define LEN_INLSTRUCT 37 + +# NLFIT parameters. These parameters are stored in the INLFIT structure, +# and passed without change to the NLFIT package. The NLFIT descriptor +# is stored here as well. + +#define IN_TYPE Memi[$1+0] # calculation type (TY_REAL, TY_DOUBLE) +define IN_FUNC Memi[$1+1] # fitting function +define IN_DFUNC Memi[$1+2] # derivative function +define IN_NPARAMS Memi[$1+3] # number of parameters +define IN_NFPARAMS Memi[$1+4] # number of fitted parameters +define IN_PARAM MEMP[$1+5] # pointer to parameter vector +define IN_DPARAM MEMP[$1+6] # pointer to par. change vector +define IN_PLIST MEMP[$1+7] # parameter list +define IN_MAXITER Memi[$1+8] # max number of iterations + +# INLFIT parameters used to keep track of the number of variables and +# number of points in the fit. These numbers are used to decide buffer +# reallocation. + +define IN_NVARS Memi[$1+9] # number of variables +define IN_NPTS Memi[$1+10] # number of points + +# INLFIT floating point substructure. This substructure is used to +# store a pointer to a separate buffer, containing floating point +# numbers. + +define IN_SFLOAT MEMP[$1+11] # pointer to subs. with reals/doubles + +# INLFIT parameters used for automatic data rejection. The rejection +# limits and the grow radius are stored in the floating point substructure. + +define IN_NREJECT Memi[$1+12] # number of rejection iteration + +# INLFIT parameters used to store the rejected point counter, and a +# pointer to the rejected point list. + +define IN_NREJPTS Memi[$1+13] # number of rejected points +define IN_REJPTS MEMP[$1+14] # pointer to buffer with rejected pts. + +# INLFIT parameters used to store user defined procedures addresses. +# These parameters are used by the zcall*() procedures. + +define IN_UAXES Memi[$1+15] # plot function +define IN_UCOLON Memi[$1+16] # default colon command +define IN_UFIT Memi[$1+17] # default interactive fit command + +# INLFIT parameters used to store pointers to separate buffers, containing +# the minimum and maximum values of all the input variables. The number +# of variables is kept as well. + +define IN_XMIN MEMP[$1+18] # pointer to buffer with min. values +define IN_XMAX MEMP[$1+19] # pointer to buffer with max. values + +# INLFIT flags. + +define IN_OVERPLOT Memi[$1+20] # overplot next plot ? +define IN_PLOTFIT Memi[$1+21] # overplot fit ? +define IN_FITERROR Memi[$1+22] # error fit code + +# INLFIT string parameters used for interactive graphics. These are +# pointers to the actual strings. + +define IN_LABELS MEMP[$1+23] # standard axis labels +define IN_UNITS MEMP[$1+24] # standard axis units +define IN_FLABELS MEMP[$1+25] # function and fit labels +define IN_FUNITS MEMP[$1+26] # function and fit units +define IN_PLABELS MEMP[$1+27] # parameter labels +define IN_PUNITS MEMP[$1+28] # parameter units +define IN_VLABELS MEMP[$1+29] # variable labels +define IN_VUNITS MEMP[$1+30] # variable units +define IN_USERLABELS MEMP[$1+31] # user plot labels +define IN_USERUNITS MEMP[$1+32] # user plot units +define IN_HELP MEMP[$1+33] # help file name +define IN_PROMPT MEMP[$1+34] # help prompt + +# INLFIT graph key definitions. + +define IN_GKEY Memi[$1+35] # current graph key +define IN_SGAXES MEMP[$1+36] # pointer to subs. with graph keys + +# next free location ($1 + 37) == LEN_INLSTRUCT + + +# ---------------------------------------------------------------------- +# Floating point number substructures (real, double). This is an easy way +# to avoid having to deal with mixed floating point types in the main +# structure. The macro parameter is the main structure pointer. The +# substructure used depends on the calculation type. + +# Substructure length + +define LEN_INLFLOAT 4 + +# Real version + +define IN_TOLR Memr[IN_SFLOAT($1)+0] # tolerance of convergence +define IN_LOWR Memr[IN_SFLOAT($1)+1] # low rejection value +define IN_HIGHR Memr[IN_SFLOAT($1)+2] # high rejection value +define IN_GROWR Memr[IN_SFLOAT($1)+3] # rejection growing radius + +# Double precission version + +define IN_TOLD Memd[IN_SFLOAT($1)+0] # tolerance of convergence +define IN_LOWD Memd[IN_SFLOAT($1)+1] # low rejection value +define IN_HIGHD Memd[IN_SFLOAT($1)+2] # high rejection value +define IN_GROWD Memd[IN_SFLOAT($1)+3] # rejection growing radius + + +# ---------------------------------------------------------------------- +# Graph axes substructure. The macro parameters are the pointer to the +# main structure, and the key number. The actual size of the graph axes +# buffer will be equal to the maximum number of keys (IN_GKEYS) times +# the substructure length (LEN_INLGRAPH). The type is one of the possible +# codes for KEY_TYPES, and the number is used to keep track of the variable +# or user supplied function numbers. + +# Substructure length + +define LEN_INLGRAPH 4 + +# Substructure definition + +define IN_GXTYPE Memi[IN_SGAXES($1)+($2-1)*LEN_INLGRAPH+0] # x axis type +define IN_GXNUMBER Memi[IN_SGAXES($1)+($2-1)*LEN_INLGRAPH+1] # x axis num. +define IN_GYTYPE Memi[IN_SGAXES($1)+($2-1)*LEN_INLGRAPH+2] # y axis type +define IN_GYNUMBER Memi[IN_SGAXES($1)+($2-1)*LEN_INLGRAPH+3] # y axis num. diff --git a/pkg/xtools/inlfit/inlgfit.key b/pkg/xtools/inlfit/inlgfit.key new file mode 100644 index 00000000..c01f9a9d --- /dev/null +++ b/pkg/xtools/inlfit/inlgfit.key @@ -0,0 +1,77 @@ +1. INTERACTIVE NONLINEAR LEAST SQUARES FITTING CURSOR OPTIONS + +? Print options +c Print coordinates and fit of point nearest the cursor +d Delete point nearest the cursor +f Do the fit and redraw or overplot the graph +g Redefine graph keys. The following data types may be along + either axis. + function Dependent variable, or function + fit Fitted value + residuals Residuals (function - fit) + ratio Ratio (function / fit) + nonlinear Nonlinear component of function + var n Independent variable number "n" + identifier Independent variable "identifier" (if defined) + user n User defined plot function (if defined) +h-l Graph keys. The defaults are the following. + h=(function, fit) + i=(function, residual) + j=(function, ratio) + k=(var 1, residual) + l=(user 1, user 2) +o Overplot the next graph +q Exit interactive curve fitting +r Redraw graph +t Overplot fit +u Undelete the deleted point nearest the cursor +w Set graph window. + For help type 'w' followed by '?' after the prompt. +I Interrupt task immediately + + +2. INTERACTIVE NONLINEAR LEAST SQUARES FITTING COLON COMMANDS + +The parameters are listed or set with the following commands which may be +abbreviated. To list the value of a parameter type the command alone. + +:show [file] Print the values of the task fitting parameters +:variables [file] Print the variable names, min and max values +:data [file] Print the values of all the variables +:errors [file] Print an error analysis of the fit +:results [file] Print the results of the fit +:vshow [file] Print an error analysis and results of the fit +:page file Page through a file +:const [param] [value] Change parameter to constant parameter +:fit [param] [value] Change parameter to fitting parameter +:tolerance [value] Show/set the convergence criteria +:maxiter [value] Show/set the maximum number of fitting iterations +:nreject [value] Show/set the maximum number of rejection iterations +:low_reject [value] Show/set the low rejection threshold +:high_reject [value] Show/set the high rejection threshold +:grow [value] Show/set the rejection growing radius + +Additional commands are available for setting graph formats and manipulating +the graphics. Use the following commands for help. + +:/help Print help for graph formatting option +:.help Print help for general graphics options + + +3. INTERACTIVE NONLINEAR LEAST SQUARES FITTING GRAPH KEYS + +The graph keys are h, i, j, k, and l. The graph keys may be redefined to +put any combination of axes types along either graph axis with the 'g' key. +To define a graph key select the desired key to redefine and then specify +the axes types for the horizontal and vertical axes by a pair of comma +separated types from the following (they may be abreviated up to three +characters, except for 'identifier'): + +function Dependent variable +fit Fitted value +ratio Ratio (function / fit) +residuuals Residuals of fit (function - fit) +nonlinear Nonlinear part of data (linear component of fit subtracted) +var [n] Indepedent variable number "n" +user [n] User defined plot equation "n" (if defined) +identifier Independent variable named "identifier" (if defined) diff --git a/pkg/xtools/inlfit/inlimit.gx b/pkg/xtools/inlfit/inlimit.gx new file mode 100644 index 00000000..ed4c2b43 --- /dev/null +++ b/pkg/xtools/inlfit/inlimit.gx @@ -0,0 +1,51 @@ +include <pkg/inlfit.h> + + +# IN_LIMIT -- Compute the independent variable limits for all variables, +# and store them in the INLFIT structure. + +procedure in_limit$t (in, x, npts, nvars) + +pointer in # INLFIT descriptor +PIXEL x[ARB] # Independent values (npts * nvars) +int npts # number of points +int nvars # number of variables + +int i, j +PIXEL aux, xmin, xmax +pointer minptr, maxptr + +pointer in_getp() + +begin +# # Debug +# call eprintf ("in_limit: in=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (npts) +# call pargi (nvars) + + # Get minimum and maximum buffer pointers + minptr = in_getp (in, INLXMIN) + maxptr = in_getp (in, INLXMAX) + + # Loop over variables + do i = 1, nvars { + + # Set initial values + xmin = x[i] + xmax = x[i] + + # Search for maximum and minimum values + do j = 1, npts { + aux = x[(j - 1) * nvars + i] + if (xmin > aux) + xmin = aux + else if (xmax < aux) + xmax = aux + } + + # Enter values into the structure + Mem$t[minptr + i - 1] = xmin + Mem$t[maxptr + i - 1] = xmax + } +end diff --git a/pkg/xtools/inlfit/inlimitd.x b/pkg/xtools/inlfit/inlimitd.x new file mode 100644 index 00000000..cc0ba12e --- /dev/null +++ b/pkg/xtools/inlfit/inlimitd.x @@ -0,0 +1,51 @@ +include <pkg/inlfit.h> + + +# IN_LIMIT -- Compute the independent variable limits for all variables, +# and store them in the INLFIT structure. + +procedure in_limitd (in, x, npts, nvars) + +pointer in # INLFIT descriptor +double x[ARB] # Independent values (npts * nvars) +int npts # number of points +int nvars # number of variables + +int i, j +double aux, xmin, xmax +pointer minptr, maxptr + +pointer in_getp() + +begin +# # Debug +# call eprintf ("in_limit: in=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (npts) +# call pargi (nvars) + + # Get minimum and maximum buffer pointers + minptr = in_getp (in, INLXMIN) + maxptr = in_getp (in, INLXMAX) + + # Loop over variables + do i = 1, nvars { + + # Set initial values + xmin = x[i] + xmax = x[i] + + # Search for maximum and minimum values + do j = 1, npts { + aux = x[(j - 1) * nvars + i] + if (xmin > aux) + xmin = aux + else if (xmax < aux) + xmax = aux + } + + # Enter values into the structure + Memd[minptr + i - 1] = xmin + Memd[maxptr + i - 1] = xmax + } +end diff --git a/pkg/xtools/inlfit/inlimitr.x b/pkg/xtools/inlfit/inlimitr.x new file mode 100644 index 00000000..e85b6c62 --- /dev/null +++ b/pkg/xtools/inlfit/inlimitr.x @@ -0,0 +1,51 @@ +include <pkg/inlfit.h> + + +# IN_LIMIT -- Compute the independent variable limits for all variables, +# and store them in the INLFIT structure. + +procedure in_limitr (in, x, npts, nvars) + +pointer in # INLFIT descriptor +real x[ARB] # Independent values (npts * nvars) +int npts # number of points +int nvars # number of variables + +int i, j +real aux, xmin, xmax +pointer minptr, maxptr + +pointer in_getp() + +begin +# # Debug +# call eprintf ("in_limit: in=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (npts) +# call pargi (nvars) + + # Get minimum and maximum buffer pointers + minptr = in_getp (in, INLXMIN) + maxptr = in_getp (in, INLXMAX) + + # Loop over variables + do i = 1, nvars { + + # Set initial values + xmin = x[i] + xmax = x[i] + + # Search for maximum and minimum values + do j = 1, npts { + aux = x[(j - 1) * nvars + i] + if (xmin > aux) + xmin = aux + else if (xmax < aux) + xmax = aux + } + + # Enter values into the structure + Memr[minptr + i - 1] = xmin + Memr[maxptr + i - 1] = xmax + } +end diff --git a/pkg/xtools/inlfit/inlstrext.x b/pkg/xtools/inlfit/inlstrext.x new file mode 100644 index 00000000..b2b071d9 --- /dev/null +++ b/pkg/xtools/inlfit/inlstrext.x @@ -0,0 +1,47 @@ +include <ctype.h> + +# INLSTREXT - Extract a word (delimited substring) from a string. +# The input string is scanned from the given initial value until one +# of the delimiters is found. The delimiters are not included in the +# output word. +# Leading white spaces in a word may be optionally skipped. White +# spaces are skipped before looking at the delimiters string, so it's +# possible to remove leading white spaces and use them as delimiters +# at the same time. +# The value returned is the number of characters in the output string. +# Upon return, the pointer is located at the begining of the next word. + +int procedure inlstrext (str, ip, dict, skip, outstr, maxch) + +char str[ARB] # input string +int ip # pointer into input string +char dict[ARB] # dictionary of delimiters +int skip # skip leading white spaces ? +char outstr[ARB] # extracted word +int maxch # max number of chars + +int op +int stridx() + +begin + # Skip leading white spaces + if (skip == YES) { + while (IS_WHITE (str[ip])) + ip = ip + 1 + } + + # Process input string + for (op=1; str[ip] != EOS && op <= maxch; op=op+1) + if (stridx (str[ip], dict) == 0) { + outstr[op] = str[ip] + ip = ip + 1 + } else { + repeat { + ip = ip + 1 + } until (stridx (str[ip], dict) == 0 || str[ip] == EOS) + break + } + + outstr[op] = EOS + return (op - 1) +end diff --git a/pkg/xtools/inlfit/inlstrwrd.x b/pkg/xtools/inlfit/inlstrwrd.x new file mode 100644 index 00000000..23aa8bdf --- /dev/null +++ b/pkg/xtools/inlfit/inlstrwrd.x @@ -0,0 +1,51 @@ +# INLSTRWRD -- Search a dictionary string for a given string index number. +# This is the opposite function of strdic(), that returns the index for +# given string. The entries in the dictionary string are separated by +# a delimiter character which is the first character of the dictionary +# string. The index of the string found is returned as the function value. +# Otherwise, if there is no string for that index, a zero is returned. + +int procedure inlstrwrd (index, outstr, maxch, dict) + +int index # String index +char outstr[ARB] # Output string as found in dictionary +int maxch # Maximum length of output string +char dict[ARB] # Dictionary string + +int i, len, start, count + +int strlen() + +begin + # Clear output string + outstr[1] = EOS + + # Return if the dictionary is not long enough + if (dict[1] == EOS) + return (0) + + # Initialize counters + count = 1 + len = strlen (dict) + + # Search the dictionary string. This loop only terminates + # successfully if the index is found. Otherwise the procedure + # returns with and error condition. + for (start = 2; count < index; start = start + 1) { + if (dict[start] == dict[1]) + count = count + 1 + if (start == len) + return (0) + } + + # Extract the output string from the dictionary + for (i = start; dict[i] != EOS && dict[i] != dict[1]; i = i + 1) { + if (i - start + 1 > maxch) + break + outstr[i - start + 1] = dict[i] + } + outstr[i - start + 1] = EOS + + # Return index for output string + return (count) +end diff --git a/pkg/xtools/inlfit/innlinit.gx b/pkg/xtools/inlfit/innlinit.gx new file mode 100644 index 00000000..87c2aab1 --- /dev/null +++ b/pkg/xtools/inlfit/innlinit.gx @@ -0,0 +1,28 @@ +include "inlfitdef.h" + + +# IN_NLINIT -- Initialize (reinitialize) NLFIT descriptor. The new +# NLFIT descriptor is returned as a procedure argument. + +procedure in_nlinit$t (in, nl) + +pointer in # INLFIT descriptor +pointer nl # NLFIT descriptor + +errchk nlinit(), nlfree() + +begin +# # Debug. +# call eprintf ("in_nlinit: in=%d, nl=%d\n") +# call pargi (in) +# call pargi (nl) + + # Free old NLFIT structure if any. + if (nl != NULL) + call nlfree$t (nl) + + # Initialize new NLFIT structure. + call nlinit$t (nl, IN_FUNC (in), IN_DFUNC (in), Mem$t[IN_PARAM (in)], + Mem$t[IN_DPARAM (in)], IN_NPARAMS (in), Memi[IN_PLIST (in)], + IN_NFPARAMS (in), IN_TOL$T (in), IN_MAXITER (in)) +end diff --git a/pkg/xtools/inlfit/innlinitd.x b/pkg/xtools/inlfit/innlinitd.x new file mode 100644 index 00000000..87a82c91 --- /dev/null +++ b/pkg/xtools/inlfit/innlinitd.x @@ -0,0 +1,28 @@ +include "inlfitdef.h" + + +# IN_NLINIT -- Initialize (reinitialize) NLFIT descriptor. The new +# NLFIT descriptor is returned as a procedure argument. + +procedure in_nlinitd (in, nl) + +pointer in # INLFIT descriptor +pointer nl # NLFIT descriptor + +errchk nlinit(), nlfree() + +begin +# # Debug. +# call eprintf ("in_nlinit: in=%d, nl=%d\n") +# call pargi (in) +# call pargi (nl) + + # Free old NLFIT structure if any. + if (nl != NULL) + call nlfreed (nl) + + # Initialize new NLFIT structure. + call nlinitd (nl, IN_FUNC (in), IN_DFUNC (in), Memd[IN_PARAM (in)], + Memd[IN_DPARAM (in)], IN_NPARAMS (in), Memi[IN_PLIST (in)], + IN_NFPARAMS (in), IN_TOLD (in), IN_MAXITER (in)) +end diff --git a/pkg/xtools/inlfit/innlinitr.x b/pkg/xtools/inlfit/innlinitr.x new file mode 100644 index 00000000..21e7b932 --- /dev/null +++ b/pkg/xtools/inlfit/innlinitr.x @@ -0,0 +1,28 @@ +include "inlfitdef.h" + + +# IN_NLINIT -- Initialize (reinitialize) NLFIT descriptor. The new +# NLFIT descriptor is returned as a procedure argument. + +procedure in_nlinitr (in, nl) + +pointer in # INLFIT descriptor +pointer nl # NLFIT descriptor + +errchk nlinit(), nlfree() + +begin +# # Debug. +# call eprintf ("in_nlinit: in=%d, nl=%d\n") +# call pargi (in) +# call pargi (nl) + + # Free old NLFIT structure if any. + if (nl != NULL) + call nlfreer (nl) + + # Initialize new NLFIT structure. + call nlinitr (nl, IN_FUNC (in), IN_DFUNC (in), Memr[IN_PARAM (in)], + Memr[IN_DPARAM (in)], IN_NPARAMS (in), Memi[IN_PLIST (in)], + IN_NFPARAMS (in), IN_TOLR (in), IN_MAXITER (in)) +end diff --git a/pkg/xtools/inlfit/input.gx b/pkg/xtools/inlfit/input.gx new file mode 100644 index 00000000..4fac25a5 --- /dev/null +++ b/pkg/xtools/inlfit/input.gx @@ -0,0 +1,188 @@ +.help input + in_puti (in, param, ival) + in_putr (in, param, rval) + in_putd (in, param, dval) + in_putp (in, param, pval) + in_pstr (in, param, str) + in_pkey (in, key, axis, type, varnum) +.endhelp + +include <pkg/inlfit.h> +include "inlfitdef.h" + + +# IN_PUTI -- Put integer valued parameters. + +procedure in_puti (in, param, ival) + +pointer in # INLFIT pointer +int param # parameter to put +int ival # integer value + +begin + switch (param) { + case INLFUNCTION: + IN_FUNC (in) = ival + case INLDERIVATIVE: + IN_DFUNC (in) = ival + case INLNPARAMS: + IN_NPARAMS (in) = ival + case INLNFPARAMS: + IN_NFPARAMS (in) = ival + case INLNVARS: + IN_NVARS (in) = ival + case INLNPTS: + IN_NPTS (in) = ival + case INLMAXITER: + IN_MAXITER (in) = ival + case INLNREJECT: + IN_NREJECT (in) = ival + case INLNREJPTS: + IN_NREJPTS (in) = ival + case INLUAXES: + IN_UAXES (in) = ival + case INLUCOLON: + IN_UCOLON (in) = ival + case INLUFIT: + IN_UFIT (in) = ival + case INLOVERPLOT: + IN_OVERPLOT (in) = ival + case INLPLOTFIT: + IN_PLOTFIT (in) = ival + case INLFITERROR: + IN_FITERROR (in) = ival + case INLGKEY: + if (ival < 1 || ival > INLNGKEYS) + call error (0, "INLFIT, in_puti: Bad key number (INLGKEY)") + IN_GKEY (in) = ival + default: + call error (0, "INLFIT, in_puti: Unknown parameter") + } +end + + +$for (rd) +# IN_PUT[RD] -- Put real/double valued parameters. + +procedure in_put$t (in, param, $tval) + +pointer in # INLFIT pointer +int param # parameter to put +PIXEL $tval # value + +begin + switch (param) { + case INLTOLERANCE: + IN_TOL$T (in) = $tval + case INLLOW: + IN_LOW$T (in) = $tval + case INLHIGH: + IN_HIGH$T (in) = $tval + case INLGROW: + IN_GROW$T (in) = $tval + default: + call error (0, "INLFIT, in_put[rd]: Unknown parameter") + } +end +$endfor + + +# IN_PUTP -- Put pointer valued parameters. + +procedure in_putp (in, param, pval) + +pointer in # INLFIT pointer +int param # parameter to put +pointer pval # pointer value + +begin + switch (param) { + case INLPARAM: + IN_PARAM (in) = pval + case INLDPARAM: + IN_DPARAM (in) = pval + case INLPLIST: + IN_PLIST (in) = pval + case INLSFLOAT: + IN_SFLOAT (in) = pval + case INLREJPTS: + IN_REJPTS (in) = pval + case INLXMIN: + IN_XMIN (in) = pval + case INLXMAX: + IN_XMAX (in) = pval + case INLSGAXES: + IN_SGAXES (in) = pval + default: + call error (0, "INLFIT, in_putp: Unknown parameter") + } +end + + +# IN_PSTR -- Put string valued parameters. + +procedure in_pstr (in, param, str) + +pointer in # INLFIT pointer +int param # parameter to put +char str[ARB] # string value + +begin + switch (param) { + case INLLABELS: + call strcpy (str, Memc[IN_LABELS (in)], SZ_LINE) + case INLUNITS: + call strcpy (str, Memc[IN_UNITS (in)], SZ_LINE) + case INLFLABELS: + call strcpy (str, Memc[IN_FLABELS (in)], SZ_LINE) + case INLFUNITS: + call strcpy (str, Memc[IN_FUNITS (in)], SZ_LINE) + case INLPLABELS: + call strcpy (str, Memc[IN_PLABELS (in)], SZ_LINE) + case INLPUNITS: + call strcpy (str, Memc[IN_PUNITS (in)], SZ_LINE) + case INLVLABELS: + call strcpy (str, Memc[IN_VLABELS (in)], SZ_LINE) + case INLVUNITS: + call strcpy (str, Memc[IN_VUNITS (in)], SZ_LINE) + case INLUSERLABELS: + call strcpy (str, Memc[IN_USERLABELS (in)], SZ_LINE) + case INLUSERUNITS: + call strcpy (str, Memc[IN_USERUNITS (in)], SZ_LINE) + case INLHELP: + call strcpy (str, Memc[IN_HELP (in)], SZ_FNAME) + case INLPROMPT: + call strcpy (str, Memc[IN_PROMPT (in)], SZ_FNAME) + default: + call error (0, "INLFIT, in_pstr: Unknown parameter") + } +end + + +# IN_PKEY -- Put key parameters. + +procedure in_pkey (in, key, axis, type, varnum) + +pointer in # INLFIT pointer +int key # key to put +int axis # axis number +int type # axis type +int varnum # axis variable number + +begin + # Check ranges + if (key < 1 || key > INLNGKEYS) + call error (0, "INLFIT, in_pkey: Illegal key") + if (type < KEY_MIN || type > KEY_MAX) + call error (0, "INLFIT, in_pkey: Illegal key type") + + # Enter data + if (axis == INLXAXIS) { + IN_GXTYPE (in, key) = type + IN_GXNUMBER (in, key) = varnum + } else if (axis == INLYAXIS) { + IN_GYTYPE (in, key) = type + IN_GYNUMBER (in, key) = varnum + } else + call error (0,"INLFIT, in_pkey: Illegal axis number") +end diff --git a/pkg/xtools/inlfit/input.x b/pkg/xtools/inlfit/input.x new file mode 100644 index 00000000..db1613cb --- /dev/null +++ b/pkg/xtools/inlfit/input.x @@ -0,0 +1,211 @@ +.help input + in_puti (in, param, ival) + in_putr (in, param, rval) + in_putd (in, param, dval) + in_putp (in, param, pval) + in_pstr (in, param, str) + in_pkey (in, key, axis, type, varnum) +.endhelp + +include <pkg/inlfit.h> +include "inlfitdef.h" + + +# IN_PUTI -- Put integer valued parameters. + +procedure in_puti (in, param, ival) + +pointer in # INLFIT pointer +int param # parameter to put +int ival # integer value + +begin + switch (param) { + case INLFUNCTION: + IN_FUNC (in) = ival + case INLDERIVATIVE: + IN_DFUNC (in) = ival + case INLNPARAMS: + IN_NPARAMS (in) = ival + case INLNFPARAMS: + IN_NFPARAMS (in) = ival + case INLNVARS: + IN_NVARS (in) = ival + case INLNPTS: + IN_NPTS (in) = ival + case INLMAXITER: + IN_MAXITER (in) = ival + case INLNREJECT: + IN_NREJECT (in) = ival + case INLNREJPTS: + IN_NREJPTS (in) = ival + case INLUAXES: + IN_UAXES (in) = ival + case INLUCOLON: + IN_UCOLON (in) = ival + case INLUFIT: + IN_UFIT (in) = ival + case INLOVERPLOT: + IN_OVERPLOT (in) = ival + case INLPLOTFIT: + IN_PLOTFIT (in) = ival + case INLFITERROR: + IN_FITERROR (in) = ival + case INLGKEY: + if (ival < 1 || ival > INLNGKEYS) + call error (0, "INLFIT, in_puti: Bad key number (INLGKEY)") + IN_GKEY (in) = ival + default: + call error (0, "INLFIT, in_puti: Unknown parameter") + } +end + + + +# IN_PUT[RD] -- Put real/double valued parameters. + +procedure in_putr (in, param, rval) + +pointer in # INLFIT pointer +int param # parameter to put +real rval # value + +begin + switch (param) { + case INLTOLERANCE: + IN_TOLR (in) = rval + case INLLOW: + IN_LOWR (in) = rval + case INLHIGH: + IN_HIGHR (in) = rval + case INLGROW: + IN_GROWR (in) = rval + default: + call error (0, "INLFIT, in_put[rd]: Unknown parameter") + } +end + +# IN_PUT[RD] -- Put real/double valued parameters. + +procedure in_putd (in, param, dval) + +pointer in # INLFIT pointer +int param # parameter to put +double dval # value + +begin + switch (param) { + case INLTOLERANCE: + IN_TOLD (in) = dval + case INLLOW: + IN_LOWD (in) = dval + case INLHIGH: + IN_HIGHD (in) = dval + case INLGROW: + IN_GROWD (in) = dval + default: + call error (0, "INLFIT, in_put[rd]: Unknown parameter") + } +end + + + +# IN_PUTP -- Put pointer valued parameters. + +procedure in_putp (in, param, pval) + +pointer in # INLFIT pointer +int param # parameter to put +pointer pval # pointer value + +begin + switch (param) { + case INLPARAM: + IN_PARAM (in) = pval + case INLDPARAM: + IN_DPARAM (in) = pval + case INLPLIST: + IN_PLIST (in) = pval + case INLSFLOAT: + IN_SFLOAT (in) = pval + case INLREJPTS: + IN_REJPTS (in) = pval + case INLXMIN: + IN_XMIN (in) = pval + case INLXMAX: + IN_XMAX (in) = pval + case INLSGAXES: + IN_SGAXES (in) = pval + default: + call error (0, "INLFIT, in_putp: Unknown parameter") + } +end + + +# IN_PSTR -- Put string valued parameters. + +procedure in_pstr (in, param, str) + +pointer in # INLFIT pointer +int param # parameter to put +char str[ARB] # string value + +begin + switch (param) { + case INLLABELS: + call strcpy (str, Memc[IN_LABELS (in)], SZ_LINE) + case INLUNITS: + call strcpy (str, Memc[IN_UNITS (in)], SZ_LINE) + case INLFLABELS: + call strcpy (str, Memc[IN_FLABELS (in)], SZ_LINE) + case INLFUNITS: + call strcpy (str, Memc[IN_FUNITS (in)], SZ_LINE) + case INLPLABELS: + call strcpy (str, Memc[IN_PLABELS (in)], SZ_LINE) + case INLPUNITS: + call strcpy (str, Memc[IN_PUNITS (in)], SZ_LINE) + case INLVLABELS: + call strcpy (str, Memc[IN_VLABELS (in)], SZ_LINE) + case INLVUNITS: + call strcpy (str, Memc[IN_VUNITS (in)], SZ_LINE) + case INLUSERLABELS: + call strcpy (str, Memc[IN_USERLABELS (in)], SZ_LINE) + case INLUSERUNITS: + call strcpy (str, Memc[IN_USERUNITS (in)], SZ_LINE) + case INLHELP: + call strcpy (str, Memc[IN_HELP (in)], SZ_FNAME) + case INLPROMPT: + call strcpy (str, Memc[IN_PROMPT (in)], SZ_FNAME) + default: + call error (0, "INLFIT, in_pstr: Unknown parameter") + } +end + + +# IN_PKEY -- Put key parameters. + +procedure in_pkey (in, key, axis, type, varnum) + +pointer in # INLFIT pointer +int key # key to put +int axis # axis number +int type # axis type +int varnum # axis variable number + +begin + # Check ranges + if (key < 1 || key > INLNGKEYS) + call error (0, "INLFIT, in_pkey: Illegal key") + if (type < KEY_MIN || type > KEY_MAX) + call error (0, "INLFIT, in_pkey: Illegal key type") + + # Enter data + if (axis == INLXAXIS) { + IN_GXTYPE (in, key) = type + IN_GXNUMBER (in, key) = varnum + } else if (axis == INLYAXIS) { + IN_GYTYPE (in, key) = type + IN_GYNUMBER (in, key) = varnum + } else + call error (0,"INLFIT, in_pkey: Illegal axis number") +end diff --git a/pkg/xtools/inlfit/inrefit.gx b/pkg/xtools/inlfit/inrefit.gx new file mode 100644 index 00000000..2effe21e --- /dev/null +++ b/pkg/xtools/inlfit/inrefit.gx @@ -0,0 +1,67 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# IN_REFIT -- Refit a function. This procedure is analogous to in_fit(), +# except that this one does not initialize the weigths and the rejected +# point list, and it does not reject points after the fit, because it is +# intended to be called from the data rejection procedure. + +procedure in_refit$t (in, nl, x, y, wts, npts, nvars, wtflag) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +PIXEL x[ARB] # Ordinates +PIXEL y[npts] # Data to be fit +PIXEL wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +int wtflag # Type of weighting + +int i, ndeleted, ier +pointer rejpts +pointer in_getp() +int in_geti() + +begin +# # Debug +# call eprintf ("in_refit: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + + # Assign a zero weight to each rejected point. + rejpts = in_getp (in, INLREJPTS) + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + wts[i] = PIXEL (0.0) + } + + # Reinitialize NLFIT. + call in_nlinit$t (in, nl) + + # Check number of data points. + if (npts == 0) { + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + return + } + + # Check number of deleted points. + ndeleted = 0 + do i = 1, npts { + if (wts[i] <= PIXEL(0.0)) + ndeleted = ndeleted + 1 + } + if ((npts - ndeleted) < in_geti(in, INLNFPARAMS)) { + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + return + } + + # Refit. + call nlfit$t (nl, x, y, wts, npts, nvars, wtflag, ier) + + # Store fit status in the INLFIT structure. + call in_puti (in, INLFITERROR, ier) +end diff --git a/pkg/xtools/inlfit/inrefitd.x b/pkg/xtools/inlfit/inrefitd.x new file mode 100644 index 00000000..956e125e --- /dev/null +++ b/pkg/xtools/inlfit/inrefitd.x @@ -0,0 +1,67 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# IN_REFIT -- Refit a function. This procedure is analogous to in_fit(), +# except that this one does not initialize the weigths and the rejected +# point list, and it does not reject points after the fit, because it is +# intended to be called from the data rejection procedure. + +procedure in_refitd (in, nl, x, y, wts, npts, nvars, wtflag) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +double x[ARB] # Ordinates +double y[npts] # Data to be fit +double wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +int wtflag # Type of weighting + +int i, ndeleted, ier +pointer rejpts +pointer in_getp() +int in_geti() + +begin +# # Debug +# call eprintf ("in_refit: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + + # Assign a zero weight to each rejected point. + rejpts = in_getp (in, INLREJPTS) + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + wts[i] = double (0.0) + } + + # Reinitialize NLFIT. + call in_nlinitd (in, nl) + + # Check number of data points. + if (npts == 0) { + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + return + } + + # Check number of deleted points. + ndeleted = 0 + do i = 1, npts { + if (wts[i] <= double(0.0)) + ndeleted = ndeleted + 1 + } + if ((npts - ndeleted) < in_geti(in, INLNFPARAMS)) { + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + return + } + + # Refit. + call nlfitd (nl, x, y, wts, npts, nvars, wtflag, ier) + + # Store fit status in the INLFIT structure. + call in_puti (in, INLFITERROR, ier) +end diff --git a/pkg/xtools/inlfit/inrefitr.x b/pkg/xtools/inlfit/inrefitr.x new file mode 100644 index 00000000..3dea7f9f --- /dev/null +++ b/pkg/xtools/inlfit/inrefitr.x @@ -0,0 +1,67 @@ +include <math/nlfit.h> +include <pkg/inlfit.h> + + +# IN_REFIT -- Refit a function. This procedure is analogous to in_fit(), +# except that this one does not initialize the weigths and the rejected +# point list, and it does not reject points after the fit, because it is +# intended to be called from the data rejection procedure. + +procedure in_refitr (in, nl, x, y, wts, npts, nvars, wtflag) + +pointer in # INLFIT pointer +pointer nl # NLFIT pointer +real x[ARB] # Ordinates +real y[npts] # Data to be fit +real wts[npts] # Weights +int npts # Number of points +int nvars # Number of variables +int wtflag # Type of weighting + +int i, ndeleted, ier +pointer rejpts +pointer in_getp() +int in_geti() + +begin +# # Debug +# call eprintf ("in_refit: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + + # Assign a zero weight to each rejected point. + rejpts = in_getp (in, INLREJPTS) + do i = 1, npts { + if (Memi[rejpts+i-1] == YES) + wts[i] = real (0.0) + } + + # Reinitialize NLFIT. + call in_nlinitr (in, nl) + + # Check number of data points. + if (npts == 0) { + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + return + } + + # Check number of deleted points. + ndeleted = 0 + do i = 1, npts { + if (wts[i] <= real(0.0)) + ndeleted = ndeleted + 1 + } + if ((npts - ndeleted) < in_geti(in, INLNFPARAMS)) { + call in_puti (in, INLFITERROR, NO_DEG_FREEDOM) + return + } + + # Refit. + call nlfitr (nl, x, y, wts, npts, nvars, wtflag, ier) + + # Store fit status in the INLFIT structure. + call in_puti (in, INLFITERROR, ier) +end diff --git a/pkg/xtools/inlfit/inreject.gx b/pkg/xtools/inlfit/inreject.gx new file mode 100644 index 00000000..5aad8596 --- /dev/null +++ b/pkg/xtools/inlfit/inreject.gx @@ -0,0 +1,72 @@ +include <pkg/inlfit.h> + + +# IN_REJECT -- Reject points with large residuals from the fit. +# The sigma of the fit residuals is calculated. The rejection thresholds +# are set at low_reject*sigma and high_reject*sigma. Points outside the +# rejection threshold are rejected from the fit and flagged in the rejpts +# array. Finally, the remaining points are refit. + +procedure in_reject$t (in, nl, x, y, w, npts, nvars, wtflag) + +pointer in # INLFIT decriptor +pointer nl # NLFIT decriptor +PIXEL x[ARB] # Input ordinates (npts * nvars) +PIXEL y[npts] # Input data values +PIXEL w[npts] # Weights +int npts # Number of input points +int nvars # Number of variables +int wtflag # Type of weighting + +int i, nreject, newreject, niter +PIXEL low, high, grow +pointer sp, wts1, rejpts + +int in_geti() +PIXEL in_get$t() +pointer in_getp() + +begin +# # Debug. +# call eprintf ("in_reject: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + # Get number of reject iterations, and return if they + # are less than one. + niter = in_geti (in, INLNREJECT) + if (niter < 1) + return + + call smark (sp) + call salloc (wts1, npts, TY_PIXEL) + call amov$t (w, Mem$t[wts1], npts) + + # Get rejection parameters, and rejected point list. + low = in_get$t (in, INLLOW) + high = in_get$t (in, INLHIGH) + grow = in_get$t (in, INLGROW) + rejpts = in_getp (in, INLREJPTS) + + # Loop looking for deviant points, and refitting. + do i = 1, niter { + + # Look for new deviant points. + call in_deviant$t (nl, x, y, w, Memi[rejpts], npts, nvars, low, + high, grow, nreject, newreject) + + # Refit if there are new rejected points. + if (newreject != 0) { + call amov$t (Mem$t[wts1], w, npts) + call in_refit$t (in, nl, x, y, w, npts, nvars, wtflag) + } else + break + } + + # Update number of rejected points. + call in_puti (in, INLNREJPTS, nreject + newreject) + + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/inrejectd.x b/pkg/xtools/inlfit/inrejectd.x new file mode 100644 index 00000000..670cbce6 --- /dev/null +++ b/pkg/xtools/inlfit/inrejectd.x @@ -0,0 +1,72 @@ +include <pkg/inlfit.h> + + +# IN_REJECT -- Reject points with large residuals from the fit. +# The sigma of the fit residuals is calculated. The rejection thresholds +# are set at low_reject*sigma and high_reject*sigma. Points outside the +# rejection threshold are rejected from the fit and flagged in the rejpts +# array. Finally, the remaining points are refit. + +procedure in_rejectd (in, nl, x, y, w, npts, nvars, wtflag) + +pointer in # INLFIT decriptor +pointer nl # NLFIT decriptor +double x[ARB] # Input ordinates (npts * nvars) +double y[npts] # Input data values +double w[npts] # Weights +int npts # Number of input points +int nvars # Number of variables +int wtflag # Type of weighting + +int i, nreject, newreject, niter +double low, high, grow +pointer sp, wts1, rejpts + +int in_geti() +double in_getd() +pointer in_getp() + +begin +# # Debug. +# call eprintf ("in_reject: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + # Get number of reject iterations, and return if they + # are less than one. + niter = in_geti (in, INLNREJECT) + if (niter < 1) + return + + call smark (sp) + call salloc (wts1, npts, TY_DOUBLE) + call amovd (w, Memd[wts1], npts) + + # Get rejection parameters, and rejected point list. + low = in_getd (in, INLLOW) + high = in_getd (in, INLHIGH) + grow = in_getd (in, INLGROW) + rejpts = in_getp (in, INLREJPTS) + + # Loop looking for deviant points, and refitting. + do i = 1, niter { + + # Look for new deviant points. + call in_deviantd (nl, x, y, w, Memi[rejpts], npts, nvars, low, + high, grow, nreject, newreject) + + # Refit if there are new rejected points. + if (newreject != 0) { + call amovd (Memd[wts1], w, npts) + call in_refitd (in, nl, x, y, w, npts, nvars, wtflag) + } else + break + } + + # Update number of rejected points. + call in_puti (in, INLNREJPTS, nreject + newreject) + + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/inrejectr.x b/pkg/xtools/inlfit/inrejectr.x new file mode 100644 index 00000000..98116fe9 --- /dev/null +++ b/pkg/xtools/inlfit/inrejectr.x @@ -0,0 +1,72 @@ +include <pkg/inlfit.h> + + +# IN_REJECT -- Reject points with large residuals from the fit. +# The sigma of the fit residuals is calculated. The rejection thresholds +# are set at low_reject*sigma and high_reject*sigma. Points outside the +# rejection threshold are rejected from the fit and flagged in the rejpts +# array. Finally, the remaining points are refit. + +procedure in_rejectr (in, nl, x, y, w, npts, nvars, wtflag) + +pointer in # INLFIT decriptor +pointer nl # NLFIT decriptor +real x[ARB] # Input ordinates (npts * nvars) +real y[npts] # Input data values +real w[npts] # Weights +int npts # Number of input points +int nvars # Number of variables +int wtflag # Type of weighting + +int i, nreject, newreject, niter +real low, high, grow +pointer sp, wts1, rejpts + +int in_geti() +real in_getr() +pointer in_getp() + +begin +# # Debug. +# call eprintf ("in_reject: in=%d, nl=%d, npts=%d, nvars=%d\n") +# call pargi (in) +# call pargi (nl) +# call pargi (npts) +# call pargi (nvars) + + # Get number of reject iterations, and return if they + # are less than one. + niter = in_geti (in, INLNREJECT) + if (niter < 1) + return + + call smark (sp) + call salloc (wts1, npts, TY_REAL) + call amovr (w, Memr[wts1], npts) + + # Get rejection parameters, and rejected point list. + low = in_getr (in, INLLOW) + high = in_getr (in, INLHIGH) + grow = in_getr (in, INLGROW) + rejpts = in_getp (in, INLREJPTS) + + # Loop looking for deviant points, and refitting. + do i = 1, niter { + + # Look for new deviant points. + call in_deviantr (nl, x, y, w, Memi[rejpts], npts, nvars, low, + high, grow, nreject, newreject) + + # Refit if there are new rejected points. + if (newreject != 0) { + call amovr (Memr[wts1], w, npts) + call in_refitr (in, nl, x, y, w, npts, nvars, wtflag) + } else + break + } + + # Update number of rejected points. + call in_puti (in, INLNREJPTS, nreject + newreject) + + call sfree (sp) +end diff --git a/pkg/xtools/inlfit/inrms.gx b/pkg/xtools/inlfit/inrms.gx new file mode 100644 index 00000000..a2c5015b --- /dev/null +++ b/pkg/xtools/inlfit/inrms.gx @@ -0,0 +1,31 @@ +# IN_RMS -- Compute rms of points which have a non-zero weight. + +PIXEL procedure in_rms$t (y, fit, wts, npts) + +PIXEL y[npts] # function +PIXEL fit[npts] # fit +PIXEL wts[npts] # weights +int npts # number of points + +int i, ndata +PIXEL resid, rms + +begin + rms = PIXEL (0.0) + ndata = 0 + + do i = 1, npts { + if (wts[i] == PIXEL (0.0)) + next + resid = y[i] - fit[i] + rms = rms + resid * resid + ndata = ndata + 1 + } + + if (ndata > 0) + rms = sqrt (rms / ndata) + else + rms = PIXEL (0.0) + + return (rms) +end diff --git a/pkg/xtools/inlfit/inrmsd.x b/pkg/xtools/inlfit/inrmsd.x new file mode 100644 index 00000000..26800de7 --- /dev/null +++ b/pkg/xtools/inlfit/inrmsd.x @@ -0,0 +1,31 @@ +# IN_RMS -- Compute rms of points which have a non-zero weight. + +double procedure in_rmsd (y, fit, wts, npts) + +double y[npts] # function +double fit[npts] # fit +double wts[npts] # weights +int npts # number of points + +int i, ndata +double resid, rms + +begin + rms = double (0.0) + ndata = 0 + + do i = 1, npts { + if (wts[i] == double (0.0)) + next + resid = y[i] - fit[i] + rms = rms + resid * resid + ndata = ndata + 1 + } + + if (ndata > 0) + rms = sqrt (rms / ndata) + else + rms = double (0.0) + + return (rms) +end diff --git a/pkg/xtools/inlfit/inrmsr.x b/pkg/xtools/inlfit/inrmsr.x new file mode 100644 index 00000000..e28696a1 --- /dev/null +++ b/pkg/xtools/inlfit/inrmsr.x @@ -0,0 +1,31 @@ +# IN_RMS -- Compute rms of points which have a non-zero weight. + +real procedure in_rmsr (y, fit, wts, npts) + +real y[npts] # function +real fit[npts] # fit +real wts[npts] # weights +int npts # number of points + +int i, ndata +real resid, rms + +begin + rms = real (0.0) + ndata = 0 + + do i = 1, npts { + if (wts[i] == real (0.0)) + next + resid = y[i] - fit[i] + rms = rms + resid * resid + ndata = ndata + 1 + } + + if (ndata > 0) + rms = sqrt (rms / ndata) + else + rms = real (0.0) + + return (rms) +end diff --git a/pkg/xtools/inlfit/mkpkg b/pkg/xtools/inlfit/mkpkg new file mode 100644 index 00000000..4dd38bfb --- /dev/null +++ b/pkg/xtools/inlfit/mkpkg @@ -0,0 +1,122 @@ +# INLFIT mkpkg file + +$checkout libxtools.a lib$ +$update libxtools.a +$checkin libxtools.a lib$ +$exit + +generic: + $set GEN = "$$generic -k -t rd" + $ifnewer (inget.gx, inget.x) + $generic -k -o inget.x inget.gx + $endif + $ifnewer (input.gx, input.x) + $generic -k -o input.x input.gx + $endif + + $ifnewer (indump.gx, indumpr.x) $(GEN) indump.gx $endif + + $ifnewer (incopy.gx, incopyr.x) $(GEN) incopy.gx $endif + $ifnewer (infree.gx, infreer.x) $(GEN) infree.gx $endif + $ifnewer (ininit.gx, ininitr.x) $(GEN) ininit.gx $endif + $ifnewer (innlinit.gx, innlinitr.x) $(GEN) innlinit.gx $endif + + $ifnewer (indeviant.gx, indeviantr.x) $(GEN) indeviant.gx $endif + $ifnewer (inerrors.gx, inerrorsr.x) $(GEN) inerrors.gx $endif + $ifnewer (infit.gx, infitr.x) $(GEN) infit.gx $endif + $ifnewer (inlimit.gx, inlimitr.x) $(GEN) inlimit.gx $endif + $ifnewer (inrefit.gx, inrefitr.x) $(GEN) inrefit.gx $endif + $ifnewer (inreject.gx, inrejectr.x) $(GEN) inreject.gx $endif + $ifnewer (inrms.gx, inrmsr.x) $(GEN) inrms.gx $endif + + $ifnewer (ingaxes.gx, ingaxesr.x) $(GEN) ingaxes.gx $endif + $ifnewer (ingcolon.gx, ingcolonr.x) $(GEN) ingcolon.gx $endif + $ifnewer (ingdata.gx, ingdatar.x) $(GEN) ingdata.gx $endif + $ifnewer (ingdelete.gx, ingdeleter.x) $(GEN) ingdelete.gx $endif + $ifnewer (ingerrors.gx, ingerrorsr.x) $(GEN) ingerrors.gx $endif + $ifnewer (ingfit.gx, ingfitr.x) $(GEN) ingfit.gx $endif + $ifnewer (inggraph.gx, inggraphr.x) $(GEN) inggraph.gx $endif + $ifnewer (ingnearest.gx, ingnearestr.x) $(GEN) ingnearest.gx $endif + $ifnewer (ingparams.gx, ingparamsr.x) $(GEN) ingparams.gx $endif + $ifnewer (ingresults.gx, ingresultsr.x) $(GEN) ingresults.gx $endif + $ifnewer (ingshow.gx, ingshowr.x) $(GEN) ingshow.gx $endif + $ifnewer (inguaxes.gx, inguaxesr.x) $(GEN) inguaxes.gx $endif + $ifnewer (ingucolon.gx, ingucolonr.x) $(GEN) ingucolon.gx $endif + $ifnewer (ingundelete.gx, ingundeleter.x) $(GEN) ingundelete.gx $endif + $ifnewer (ingvars.gx, ingvarsr.x) $(GEN) ingvars.gx $endif + $ifnewer (ingvshow.gx, ingvshowr.x) $(GEN) ingvshow.gx $endif + ; + +libxtools.a: + + $ifeq (USE_GENERIC, yes) $call generic $endif + + incopyd.x <pkg/inlfit.h> "inlfitdef.h" + incopyr.x <pkg/inlfit.h> "inlfitdef.h" + indeviantd.x <mach.h> + indeviantr.x <mach.h> + indumpd.x <pkg/inlfit.h> "inlfitdef.h" + indumpr.x <pkg/inlfit.h> "inlfitdef.h" + inerrorsd.x <pkg/inlfit.h> <math/nlfit.h> + inerrorsr.x <pkg/inlfit.h> <math/nlfit.h> + infitd.x <pkg/inlfit.h> <math/nlfit.h> + infitr.x <pkg/inlfit.h> <math/nlfit.h> + infreed.x "inlfitdef.h" + infreer.x "inlfitdef.h" + ingaxesd.x <pkg/inlfit.h> <pkg/gtools.h> + ingaxesr.x <pkg/inlfit.h> <pkg/gtools.h> + ingcolond.x <pkg/inlfit.h> <error.h> <gset.h> + ingcolonr.x <pkg/inlfit.h> <error.h> <gset.h> + ingdatar.x <pkg/inlfit.h> + ingdatad.x <pkg/inlfit.h> + ingdefkey.x <pkg/inlfit.h> "inlfitdef.h" + ingdeleted.x <gset.h> <mach.h> <pkg/gtools.h> + ingdeleter.x <gset.h> <mach.h> <pkg/gtools.h> + ingerrorsd.x <pkg/inlfit.h> <math/nlfit.h> + ingerrorsr.x <pkg/inlfit.h> <math/nlfit.h> + inget.x <pkg/inlfit.h> "inlfitdef.h" + ingfitd.x <pkg/inlfit.h> <math/nlfit.h> <error.h> <mach.h>\ + <pkg/gtools.h> + ingfitr.x <pkg/inlfit.h> <math/nlfit.h> <error.h> <mach.h>\ + <pkg/gtools.h> + inggetlabel.x <pkg/inlfit.h> + inggraphd.x <pkg/inlfit.h> <math/nlfit.h> <gset.h>\ + <pkg/gtools.h> + inggraphr.x <pkg/inlfit.h> <math/nlfit.h> <gset.h>\ + <pkg/gtools.h> + ingnearestd.x <mach.h> <pkg/gtools.h> + ingnearestr.x <mach.h> <pkg/gtools.h> + ingparamsd.x <pkg/inlfit.h> <math/nlfit.h> <pkg/gtools.h> + ingparamsr.x <pkg/inlfit.h> <math/nlfit.h> <pkg/gtools.h> + ingresultsr.x <pkg/inlfit.h> + ingresultsd.x <pkg/inlfit.h> + ingshowd.x <pkg/inlfit.h> + ingshowr.x <pkg/inlfit.h> + inguaxesd.x <pkg/inlfit.h> <math/nlfit.h> + inguaxesr.x <pkg/inlfit.h> <math/nlfit.h> + ingucolond.x + ingucolonr.x + ingufit.x + ingundeleted.x <gset.h> <mach.h> <pkg/gtools.h> + ingundeleter.x <gset.h> <mach.h> <pkg/gtools.h> + ingvarsr.x <pkg/inlfit.h> + ingvarsd.x <pkg/inlfit.h> + ingvshowd.x <pkg/inlfit.h> + ingvshowr.x <pkg/inlfit.h> + ininitd.x <pkg/inlfit.h> "inlfitdef.h" + ininitr.x <pkg/inlfit.h> "inlfitdef.h" + inlimitd.x <pkg/inlfit.h> + inlimitr.x <pkg/inlfit.h> + inlstrext.x <ctype.h> + inlstrwrd.x + innlinitd.x "inlfitdef.h" + innlinitr.x "inlfitdef.h" + input.x <pkg/inlfit.h> "inlfitdef.h" + inrefitd.x <pkg/inlfit.h> <math/nlfit.h> + inrefitr.x <pkg/inlfit.h> <math/nlfit.h> + inrejectd.x <pkg/inlfit.h> + inrejectr.x <pkg/inlfit.h> + inrmsd.x + inrmsr.x + ingtitle.x <pkg/gtools.h> + ; diff --git a/pkg/xtools/intrp.f b/pkg/xtools/intrp.f new file mode 100644 index 00000000..3ebb23bb --- /dev/null +++ b/pkg/xtools/intrp.f @@ -0,0 +1,292 @@ + subroutine intrp (itab, xtab, ytab, ntab, x, y, ierr) +c +c Interpolator using CODIM1 algorithm which is admittedly +c obscure but works well. +c +c itab - a label between 1 and 20 to identify the table and its +c most recent search index +c xtab - array of length ntab containing the x-values +c ytab - y-values +c ntab - number of x,y pairs in the table +c x - independent for which a y-value is desired +c y - returned interpolated (or extrapolated) value +c ierr - =0 for ok, -1 for extrapolation +c + real xtab(ntab), ytab(ntab), x, y + integer itab, ierr + real t(4), u(4) +c integer savind +c data savind/-1/ +c +c----- Only 1 pt in table + if (ntab .eq. 1) then + y = ytab(1) + ierr = 0 + return + endif +c +c----- +c Locate search index + call srch (itab, x, xtab, ntab, index, ierr) +c if (index .eq. savind) go to 2000 +c savind = index +c +c----- +c Set interpolator index flags + i1 = 2 + i2 = 3 + iload = max0 (index-2, 1) +c + if (ntab .gt. 2) then + if (index.eq. 2) i2 = 4 +c + if (index.eq.ntab) i1 = 1 + endif +c + if (index.gt.2 .and. index.lt.ntab) then + i1 = 1 + i2 = 4 + endif +c----- +c Load interpolation arrays + do 1000 i = i1, i2 + j = iload + (i-i1) + t(i) = xtab (j) + u(i) = ytab (j) +1000 continue +c +c----- +c Get interpolated value +2000 call codim1 (x, t, u, i1, i2, y) + return + end +c +c-------------------------------------------------------------- +c + subroutine srch (itab, x, xtab, ntab, index, ierr) +c +c Search table of x-values to bracket the desired interpolant, x +c +c The returned search index will be: +c 2 - if extrapolation below the table is required +c ntab - above +c index - points to value just above x in the table if bounded. +c +c The index is saved as a starting point for subsequent entries +c in an array indexed through 'itab' which serves to label the +c set of saved search indices. Itab may be between 1 and 20. +c +c itab - The table identifier (1-20) +c x - The value for which an index is desired +c xtab - The table containing the x-values (array of length ntab) +c ntab - number of elements in the table +c index - returned index into the table (points just above x) +c ierr - 0 for ok, -1 for extrapolation +c + integer insave(20), ntab, index, ind + real xtab(ntab), x +c +c intialize insaved indices + data insave/20*0/ +c +c----- +c Determine direction of table, ascending or descending + idir = sign (1.0, xtab(ntab) - xtab(1)) +c +c----- +c Reset error flag + ierr = 0 +c +c----- +c Check for previous insaved index + last = insave(itab) + if (last .eq. 0 .or. last .gt. ntab) then +c +c----- +c no previous entry + isrch = 1 +c check for extrapolation + if ((x-xtab( 1)) * idir .lt. 0.0) go to 2000 + if ((x-xtab(ntab)) * idir .gt. 0.0) go to 2100 + else +c +c----- +c previous entry left a valid index + isrch = last +c +c check for still wihin bounds - difference from above should be opposite +c sign of difference from below +c + if ((xtab(last)-x) * (xtab(last-1)-x) .lt. 0.0) then + index = last + return + endif + endif +c +c ----- +c Begin searching - first determine direction +c + if ((x - xtab(isrch)) * idir .gt. 0.0) then +c forward + do 1100 i = isrch+1, ntab + if ((x-xtab(i)) * idir .gt. 0.0) go to 1100 + go to 1500 +1100 continue +c fall thru implies extrapolation required at high end + go to 2100 + else +c +c----- +c negative direction search + do 1200 i = isrch-1,1,-1 + if ((x-xtab(i)) * idir .lt. 0.0) go to 1200 + go to 1400 +1200 continue +c fall through implies extrapolation at low end + go to 2000 + endif +c +c----- +c point has been bounded +1400 index = i + 1 + go to 3000 +1500 index = i + go to 3000 +c +c----- +c extrapolations +2000 index = 2 + ierr = -1 + go to 3000 +2100 index = ntab + ierr = -1 + go to 3000 +c +c----- +c insave index +3000 insave(itab) = index + return +c +c------ +c Entry to reset saved index + entry intrp0 (itab) +c + insave(itab) = 0 + return +c +c----- +c Entry to return current index + entry intrpi (itab, ind) +c + ind = insave(itab) + return + end +c +c------------------------------------------------------------------- +c + subroutine codim1 (x, t, u, i1, i2, y) +c +c this subroutine performs an interposlation in a fashion +c not really understandable, but it works well. +c +c x - input independent variable +c t - array of 4 table independents surrounding x if possible +c u - array of 4 table dependents corresponding to the t array +c +c i1, i2 - indicators as follows: +c +c i1 = 1, i2 = 4 : 4 pts available in t and u arrays +c i1 = 1, i2 = 3 : 3 pts available (x near right edge of table) +c i1 = 2, i2 = 4 : (x near left edge of table) +c i1 = 2, i2 = 3 : 2 pts available +c i1 = 3, i3 = 3 : 1 pt available +c +c y - output interpolated (or extrapolated) dependent value +c + real t(4), u(4), x, y + integer i1, i2 +c +c variable xk affects the extrapolation procedure. a value of -1.0 +c appears to be a reliable value. +c + data xk/-1.0/ +c + v = x +c the following code is extracted from an original source +c + a2=v-t(2) + al=a2/(t(3)-t(2)) + s=al*u(3)+(1.-al)*u(2) + if(i1.gt.1.and.i2.lt.4)goto1530 + a3=v-t(3) + if(i1.gt.1)goto1185 +1180 a1=v-t(1) + c1=a2/(t(1)-t(2))*a3/(t(1)-t(3)) + c2=a1/(t(2)-t(1))*a3/(t(2)-t(3)) + c3=a1/(t(3)-t(1))*a2/(t(3)-t(2)) + p1=c1*u(1)+c2*u(2)+c3*u(3) + if(i2.lt.4)goto1400 +1185 a4=v-t(4) + c4=a3/(t(2)-t(3))*a4/(t(2)-t(4)) + c5=a2/(t(3)-t(2))*a4/(t(3)-t(4)) + c6=a2/(t(4)-t(2))*a3/(t(4)-t(3)) + p2=c4*u(2)+c5*u(3)+c6*u(4) + if(i1.eq.1)goto1500 +1200 if(xk.lt.0.)goto1230 + xe=xk + goto1260 +1230 slope1=abs((u(4)-u(3))/(t(4)-t(3))) + slope2=abs((u(3)-u(2))/(t(3)-t(2))) + xe=1.0 + if(slope1+slope2.ne.0.)xe=1.-abs(slope1-slope2)/(slope1+slope2) +1260 p1=s+xe*(p2-s) + goto1500 +1400 if(xk.lt.0.)goto1430 + xe=xk + goto1460 +1430 slope1=abs((u(2)-u(1))/(t(2)-t(1))) + slope2=abs((u(3)-u(2))/(t(3)-t(2))) + xe=1.0 + if(slope1+slope2.ne.0.)xe=1.-abs(slope1-slope2)/(slope1+slope2) +1460 p2=s+xe*(p1-s) +1500 e1=abs(p1-s) + e2=abs(p2-s) + if(e1+e2.gt.0.)goto1560 +1530 z=s + goto1700 +1560 bt=(e1*al)/(e1*al+(1.-al)*e2) + z=bt*p2+(1.-bt)*p1 +c +1700 y = z + return + end +c +c---------------------------------------------------------------------- +c + subroutine lintrp (itab, xtab, ytab, ntab, x, y, ierr) +c +c Linear interpolator with last index save +c +c Arguments are identical to INTRP, and uses the same index search +c scheme so that values for ITAB should not clash with calls +c to INTRP and LINTRP. +c + real xtab(ntab), ytab(ntab), x , y + integer itab, ierr +c +c----- Only 1 pt in table + if (ntab .eq. 1) then + y = ytab (1) + ierr = 0 + return + endif +c +c-----locate search index + call srch (itab, x, xtab, ntab, index, ierr) +c +c----- index points just above x + y = ytab(index-1) + (x - xtab(index-1)) * + 1 (ytab(index) - ytab(index-1)) / (xtab(index) - xtab(index-1)) +c + return + end diff --git a/pkg/xtools/isdir.x b/pkg/xtools/isdir.x new file mode 100644 index 00000000..297c5cb8 --- /dev/null +++ b/pkg/xtools/isdir.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <finfo.h> + +# ISDIRECTORY -- Test whether the named file is a directory. Check first to +# see if it is a subdirectory of the current directory; otherwise look in +# the environment to see if it is a logical directory. If VFN is a directory, +# return the OS pathname of the directory in pathname, and the number of +# chars in the pathname as the function value. Otherwise return 0. + +int procedure isdirectory (vfn, pathname, maxch) + +char vfn[ARB] # name to be tested +char pathname[ARB] # receives path of directory +int maxch # max chars out + +bool isdir +pointer sp, fname, op +int ip, fd, nchars, ch +long file_info[LEN_FINFO] +int finfo(), diropen(), gstrcpy(), strlen() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Copy the VFN string, minus any whitespace on either end. + op = fname + for (ip=1; vfn[ip] != EOS; ip=ip+1) { + ch = vfn[ip] + if (!IS_WHITE (ch)) { + Memc[op] = ch + op = op + 1 + } + } + Memc[op] = EOS + + isdir = false + if (finfo (Memc[fname], file_info) != ERR) { + isdir = (FI_TYPE(file_info) == FI_DIRECTORY) + + if (isdir) { + call fdirname (Memc[fname], pathname, maxch) + nchars = strlen (pathname) + } + + } else { + # If we get here, either VFN is a logical directory (with the + # $ omitted), or it is the name of a new file. + + Memc[op] = '$' + Memc[op+1] = EOS + ifnoerr (fd = diropen (Memc[fname], 0)) { + call close (fd) + isdir = true + } + + nchars = gstrcpy (Memc[fname], pathname, maxch) + } + + call sfree (sp) + if (isdir) + return (nchars) + else { + pathname[1] = EOS + return (0) + } +end diff --git a/pkg/xtools/mef/Notes b/pkg/xtools/mef/Notes new file mode 100644 index 00000000..7f781840 --- /dev/null +++ b/pkg/xtools/mef/Notes @@ -0,0 +1,26 @@ + +mefwrhdr.x + Previuolsy we changed the value of INHERIT to NO. Now we pass + the card to the output file unchanged with the exception when + the output file is new, then we do not pass it along. 3/4/98 + +mefrdhdr.x + When a kernel section is given in the input file, it is + necessary to read the entire header in memory rather + than the 1st block. An error was found trying to get EXTNAME + value when the keyword was not located in the 1st block. + nz 10/2/03 +mefldhdr.x + New routine to read the entire header in memory. 10.02.03 + +================================================== + +mefrdhdr.x + Change mef_rdhdr...() to be a function now rather than a + procedure. This way we can return and EOF value to the + calling routine. + revised. Used mef_ldhdr() now and discard rd1st and rd2end. + Took out any eprintf statement and made the code much simpler. + Jan.7.04 + + diff --git a/pkg/xtools/mef/mefappfile.x b/pkg/xtools/mef/mefappfile.x new file mode 100644 index 00000000..eae4536b --- /dev/null +++ b/pkg/xtools/mef/mefappfile.x @@ -0,0 +1,109 @@ +include <pkg/mef.h> + +# MEFFAPPFILE.X -- Set of routines to append a FITS units to an FITS file. +# meff_app_file(mefi, mefo) +# mef_pakwr (out, card) +# mef_wrpgcount (out) +# mef_wrblank (out, nlines) + + +# MEF_APP_FILE -- Append a FITS file to an existant file. This means the +# first input unit needs to be changed from a Primary to an Extension Unit. + +procedure mef_app_file (mefi, mefo) + +pointer mefi #I input mef descriptor +pointer mefo #O output mef descriptor + +char dname[1] +int off, status +bool in_phdu +int access(), mef_rdhdr_gn() + +errchk mef_rdhdr_gn + +begin + + # If output file does not exist create a dummy extension + if (access(MEF_FNAME(mefo), 0,0) == NO) { + dname[1] = EOS + call mef_dummyhdr (MEF_FD(mefo),dname) + MEF_ACMODE(mefo) = APPEND + } + + in_phdu = true # The input file has a PHDU + + # Read the first input header unit (PHDU) and change to extension + # unit while writing to output file. + status = mef_rdhdr_gn (mefi,0) + if (status == EOF) + call error (13, "EOF encountered on input file") + call mef_wrhdr (mefi, mefo, in_phdu) + + # Check for dataless unit; if so the data pointer is at the + # end of the last header block. + + if (MEF_POFF(mefi) == INDEFI) + off = MEF_HOFF(mefi) + ((MEF_HSIZE(mefi)+2879)/2880)*1440 + else + off = MEF_POFF(mefi) + + # Now copy the data + call seek (MEF_FD(mefi), off) + call fcopyo (MEF_FD(mefi), MEF_FD(mefo)) +end + + +# MEF_PAKWR -- Pack a character buffer and write to the output buffer. + +procedure mef_pakwr (out, card) + +int out #I Output file descriptor +char card[ARB] #I Input FITS card + +begin + call achtcb (card, card, 80) + call write(out, card, 40) +end + + +# MEF_WRPGCOUNT -- Write PCOUNT and GCOUNT to the output buffer. + +procedure mef_wrpgcount (out) + +int out #I file descriptor + +char line[80] + +begin + call mef_encodei ("PCOUNT", 0, line, "No 'random' parameters") + call mef_pakwr (out, line) + call mef_encodei ("GCOUNT", 1, line, "Only one group") + call mef_pakwr (out, line) +end + + +# MEF_WRBLANK -- Write a number of blank lines into the output buffer. +# we reach the END card in the 1st block but we run out +# to the 2nd block in the output file. Now fill it up +# with blank. + +procedure mef_wrblank (out, olines) + +int out #I output file descriptor +int olines #I number of blank lines + +int nlines, i, nbk +char card[80] + +begin + nlines = 36 - mod(olines,36) + + do i =1, 80 + card[i] = ' ' + + call achtcb (card, card, 80) + for(i=1; i<=nlines; i=i+1) + call write(out, card, 40) + return +end diff --git a/pkg/xtools/mef/mefclose.x b/pkg/xtools/mef/mefclose.x new file mode 100644 index 00000000..cbae6d54 --- /dev/null +++ b/pkg/xtools/mef/mefclose.x @@ -0,0 +1,17 @@ +include <pkg/mef.h> + +# MEF_CLOSE -- Closes mef file descriptor and free up mef memory +# descriptor. + +procedure mef_close(mef) + +pointer mef #I Mef descriptor + +begin + call close(MEF_FD(mef)) + + if (MEF_HDRP(mef) != NULL) + call mfree(MEF_HDRP(mef), TY_CHAR) + + call mfree (mef, TY_STRUCT) +end diff --git a/pkg/xtools/mef/mefcpextn.x b/pkg/xtools/mef/mefcpextn.x new file mode 100644 index 00000000..b1d00af2 --- /dev/null +++ b/pkg/xtools/mef/mefcpextn.x @@ -0,0 +1,46 @@ +include <mach.h> +include <pkg/mef.h> + +# MEF_COPY_EXTN -- Append a FITS unit to the output file. + +procedure mef_copy_extn (mefi, mefo, gn) + +pointer mefi #I input mef descriptor +pointer mefo #I output mef descriptor +int gn #I input group number + +char ibuf[FITS_BLKSZ_CHAR] +int ndim, totpix, i, k, in, out, status +int read(), mef_rdhdr_gn(), mef_totpix() +bool iphdu + +errchk mef_rdhdr_gn + +begin + iphdu = (gn == 0) + + status = mef_rdhdr_gn (mefi, gn) + if (status == EOF) + call error (13, " EOF encountered on input file") + + call mef_wrhdr (mefi, mefo, iphdu) + MEF_ACMODE(mefo) = APPEND + + # Count the pixels and write data. + ndim = MEF_NDIM(mefi) + if (ndim > 0 || MEF_PCOUNT(mefi) > 0) { + # Set in multiple of FITS_BLKSZ_CHAR + totpix = mef_totpix(mefi) + totpix = (totpix + 1439)/1440 + + in = MEF_FD(mefi) + out = MEF_FD(mefo) + + # Position the input file to the beginning of the pixel area. + call seek (in, MEF_POFF(mefi)) + do i = 1, totpix { + k = read (in, ibuf, 1440) + call write (out, ibuf, 1440) + } + } +end diff --git a/pkg/xtools/mef/mefdummyh.x b/pkg/xtools/mef/mefdummyh.x new file mode 100644 index 00000000..ba0d38dd --- /dev/null +++ b/pkg/xtools/mef/mefdummyh.x @@ -0,0 +1,84 @@ +include <pkg/mef.h> + +# MEF_DUMMYHDR -- Write a dummy Primary header Unit with no data to a new file. +# Optionaly a header file with user keywords can be used. + +procedure mef_dummyhdr (out, hdrfname) + +int out #I File descriptor +char hdrfname[ARB] #I Header filename + +char card[LEN_CARD] +pointer sp, path, op +int n, nlines, i, nchars, FD +int strlen(), open(), getline(), strncmp() + +begin + call smark(sp) + call salloc (path, SZ_PATHNAME, TY_CHAR) + + n = 0 + call mef_encodeb ("SIMPLE", YES, card, "FITS STANDARD") + call mef_pakwr (out, card) + n = n + 1 + + call mef_encodei ("BITPIX", 8, card, "Character information") + call mef_pakwr (out, card) + n = n + 1 + + call mef_encodei ("NAXIS", 0, card, "No image data array present") + call mef_pakwr (out, card) + n = n + 1 + + call mef_encodeb ("EXTEND", YES, card, + "There maybe standard extensions") + call mef_pakwr (out, card) + n = n + 1 + + call mef_encodec ("ORIGIN", FITS_ORIGIN, strlen(FITS_ORIGIN), + card, "FITS file originator") + call mef_pakwr (out, card) + n = n + 1 + + call mef_encode_date (Memc[path], SZ_PATHNAME) + call mef_encodec ("DATE", Memc[path], strlen(Memc[path]), + card, "Date FITS file was generated") + call mef_pakwr (out, card) + n = n + 1 + + # Write a header file if one is given + if (hdrfname[1] != EOS) { + fd = open (hdrfname, READ_ONLY, TEXT_FILE) + nchars = getline(fd, Memc[path]) + repeat { + if ((strncmp (Memc[path], "SIMPLE", 6) == 0) || + (strncmp (Memc[path], "BITPIX", 6) == 0) || + (strncmp (Memc[path], "NAXIS", 5) == 0) ) + nchars = getline(fd, Memc[path]) + for (op=nchars-1; op <= LEN_CARD; op=op+1) + Memc[path+op] = ' ' + Memc[path+LEN_CARD] = EOS + call mef_pakwr (out, Memc[path]) + n = n + 1 + if (n == 36) + n = 0 + nchars = getline(fd, Memc[path]) + } until (nchars == EOF) + call close (fd) + } + + Memc[path] = ' ' + call amovkc (Memc[path], card, 80) + call strcpy ("END", card, 3) + card[4] = ' ' # Clear EOS mark + call mef_pakwr (out, card) + + n = n + 1 + + call amovkc (" ", card, 80) + nlines = 36 - n + for (i=1; i<= nlines; i=i+1) + call mef_pakwr (out, card) + + call sfree (sp) +end diff --git a/pkg/xtools/mef/mefencode.x b/pkg/xtools/mef/mefencode.x new file mode 100644 index 00000000..57b5637d --- /dev/null +++ b/pkg/xtools/mef/mefencode.x @@ -0,0 +1,530 @@ +include <time.h> +include <pkg/mef.h> + +# MEFENCODE -- Routines to encode keyword, value and comment into a FITS card + +define LEN_OBJECT 63 +define CENTURY 1900 + +# MEF_ENCODEB -- Procedure to encode a boolean parameter into a FITS card. + +procedure mef_encodeb (keyword, param, card, comment) + +char keyword[ARB] #I FITS keyword +int param #I integer parameter equal to YES/NO +char card[ARB] #O FITS card image +char comment[ARB] #I FITS comment string + +char truth + +begin + if (param == YES) + truth = 'T' + else + truth = 'F' + + call sprintf (card, LEN_CARD, "%-8.8s= %20c / %-47.47s") + call pargstr (keyword) + call pargc (truth) + call pargstr (comment) +end + + +# MEF_ENCODEI -- Procedure to encode an integer parameter into a FITS card. + +procedure mef_encodei (keyword, param, card, comment) + +char keyword[ARB] #I FITS keyword +int param #I integer parameter +char card[ARB] #O FITS card image +char comment[ARB] #I FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-47.47s") + call pargstr (keyword) + call pargi (param) + call pargstr (comment) +end + + +# MEF_ENCODEL -- Procedure to encode a long parameter into a FITS card. + +procedure mef_encodel (keyword, param, card, comment) + +char keyword[ARB] #I FITS keyword +long param #I long integer parameter +char card[ARB] #O FITS card image +char comment[ARB] #I FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-47.47s") + call pargstr (keyword) + call pargl (param) + call pargstr (comment) +end + + +# MEF_ENCODER -- Procedure to encode a real parameter into a FITS card. + +procedure mef_encoder (keyword, param, card, comment, precision) + +char keyword[ARB] #I FITS keyword +real param #I real parameter +char card[ARB] #O FITS card image +char comment[ARB] #I FITS comment card +int precision #I precision of real + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-47.47s") + call pargstr (keyword) + call pargi (precision) + call pargr (param) + call pargstr (comment) +end + + +# MEF_ENCODED -- Procedure to encode a double parameter into a FITS card. + +procedure mef_encoded (keyword, param, card, comment, precision) + +char keyword[ARB] #I FITS keyword +double param #I double parameter +char card[ARB] #O FITS card image +char comment[ARB] #I FITS comment string +int precision #I FITS precision + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-47.47s") + call pargstr (keyword) + call pargi (precision) + call pargd (param) + call pargstr (comment) +end + + +# MEF_ENCODE_AXIS -- Procedure to add the axis number to axis dependent +# keywords. + +procedure mef_encode_axis (root, keyword, axisno) + +char root[ARB] #I FITS root keyword +char keyword[ARB] #O FITS keyword +int axisno #I FITS axis number + +begin + call strcpy (root, keyword, SZ_KEYWORD) + call sprintf (keyword, SZ_KEYWORD, "%-5.5s%-3.3s") + call pargstr (root) + call pargi (axisno) +end + + +# MEF_ENCODEC -- Procedure to encode an IRAF string parameter into a FITS card. + +procedure mef_encodec (keyword, param, maxch, card, comment) + +char keyword[LEN_CARD] #I FITS keyword +char param[LEN_CARD] #I FITS string parameter +int maxch #I maximum number of characters in param +char card[LEN_CARD+1] #O FITS card image +char comment[LEN_CARD] #I comment string + +int nblanks, maxchar, slashp + +begin + maxchar = max(8, min (maxch, LEN_OBJECT)) + slashp = 32 + nblanks = LEN_CARD - (slashp + 1) + if (maxchar >= 19) { + slashp = 1 + nblanks = max (LEN_OBJECT - maxchar - slashp+3, 1) + } + call sprintf (card, LEN_CARD, "%-8.8s= '%*.*s' %*t/ %*.*s") + call pargstr (keyword) + call pargi (-maxchar) + call pargi (maxchar) + call pargstr (param) + call pargi (slashp) + call pargi (-nblanks) + call pargi (nblanks) + call pargstr (comment) +end + + +# MEF_ENCODE_DATE -- Procedure to encode the date in the form dd/mm/yy. + +procedure mef_encode_date (datestr, szdate) + +char datestr[ARB] # string containing the date +int szdate # number of chars in the date string + +long ctime +int time[LEN_TMSTRUCT] +long clktime() + +begin + ctime = clktime (long (0)) + call brktime (ctime, time) + + call sprintf (datestr, szdate, "%02s/%02s/%02s") + call pargi (TM_MDAY(time)) + call pargi (TM_MONTH(time)) + call pargi (mod (TM_YEAR(time), CENTURY)) +end + + +# MEF_AKWC -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure mef_akwc (keyword, value, len, comment, pn) + +char keyword[SZ_KEYWORD] # keyword name +char value[ARB] # Keyword value +int len # Lenght of value +char comment[ARB] # Comment +pointer pn # Pointer to a char area +char card[LEN_CARD] + +begin + call mef_encodec (keyword, value, len, card, comment) + call amovc (card, Memc[pn], LEN_CARD) + pn = pn + LEN_CARD +end + + +# MEF_AKWB -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure mef_akwb (keyword, value, comment, pn) + +char keyword[SZ_KEYWORD] # I keyword name +int value # I Keyword value (YES, NO) +char comment[ARB] # I Comment +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark(sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call mef_encodeb (keyword, value, Memc[pc], comment) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree(sp) +end + + +# MEF_AKWI -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure mef_akwi (keyword, value, comment, pn) + +char keyword[SZ_KEYWORD] # I keyword name +int value # I Keyword value +char comment[ARB] # I Comment +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark(sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call mef_encodei (keyword, value, Memc[pc], comment) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree(sp) +end + + +# MEF_AKWR -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure mef_akwr (keyword, value, comment, precision, pn) + +char keyword[SZ_KEYWORD] # I keyword name +real value # I Keyword value +char comment[ARB] # I Comment +int precision +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark(sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call mef_encoder (keyword, value, Memc[pc], comment, precision) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree(sp) +end + + +# MEF_AKWD -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure mef_akwd (keyword, value, comment, precision, pn) + +char keyword[SZ_KEYWORD] # I keyword name +double value # I Keyword value +char comment[ARB] # I Comment +int precision +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark(sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call mef_encoded (keyword, value, Memc[pc], comment, precision) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree(sp) +end + + +# NOTE: This local version of the xtools routine call handle starting +# index of zero (0). Taken from dataio/lib and modified. NZ March, 98 +# +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <ctype.h> + +define FIRST 1 # Default starting range +define LAST MAX_INT # Default ending range +define STEP 1 # Default step +define NULL -1 # Ranges delimiter + +# DECODE_RANGES -- Parse a string containing a list of integer numbers or +# ranges, delimited by either spaces or commas. Return as output a list +# of ranges defining a list of numbers, and the count of list numbers. +# Range limits must be positive nonnegative integers. ERR is returned as +# the function value if a conversion error occurs. The list of ranges is +# delimited by a single NULL. + +int procedure ldecode_ranges (range_string, ranges, max_ranges, nvalues) + +char range_string[ARB] # Range string to be decoded +int ranges[3, max_ranges] # Range array +int max_ranges # Maximum number of ranges +int nvalues # The number of values in the ranges + +int ip, nrange, first, last, step, ctoi() + +begin + ip = 1 + nvalues = 0 + + do nrange = 1, max_ranges - 1 { + # Defaults to all positive integers + first = FIRST + last = LAST + step = STEP + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get first limit. + # Must be a number, '-', 'x', or EOS. If not return ERR. + if (range_string[ip] == EOS) { # end of list + if (nrange == 1) { + # Null string defaults + ranges[1, 1] = first + ranges[2, 1] = last + ranges[3, 1] = step + ranges[1, 2] = NULL + nvalues = nvalues + abs (last-first) / step + 1 + return (OK) + } else { + ranges[1, nrange] = NULL + return (OK) + } + } else if (range_string[ip] == '-') + ; + else if (range_string[ip] == 'x') + ; + else if (IS_DIGIT(range_string[ip])) { # ,n.. + if (ctoi (range_string, ip, first) == 0) + return (ERR) + } else + return (ERR) + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get last limit + # Must be '-', or 'x' otherwise last = first. + if (range_string[ip] == 'x') + ; + else if (range_string[ip] == '-') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, last) == 0) + return (ERR) + } else if (range_string[ip] == 'x') + ; + else + return (ERR) + } else + last = first + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get step. + # Must be 'x' or assume default step. + if (range_string[ip] == 'x') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, step) == 0) + ; + } else if (range_string[ip] == '-') + ; + else + return (ERR) + } + + # Output the range triple. + ranges[1, nrange] = first + ranges[2, nrange] = last + ranges[3, nrange] = step + nvalues = nvalues + abs (last-first) / step + 1 + } + + return (ERR) # ran out of space +end + + +# GET_NEXT_NUMBER -- Given a list of ranges and the current file number, +# find and return the next file number. Selection is done in such a way +# that list numbers are always returned in monotonically increasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure lget_next_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number+1 is anywhere in the list, that is the next number, + # otherwise the next number is the smallest number in the list which + # is greater than number+1. + + number = number + 1 + next_number = MAX_INT + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder + step <= last) + next_number = number - remainder + step + } else if (first > number) + next_number = min (next_number, first) + } + + if (next_number == MAX_INT) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# GET_PREVIOUS_NUMBER -- Given a list of ranges and the current file number, +# find and return the previous file number. Selection is done in such a way +# that list numbers are always returned in monotonically decreasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure lget_previous_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number-1 is anywhere in the list, that is the previous number, + # otherwise the previous number is the largest number in the list which + # is less than number-1. + + number = number - 1 + next_number = 0 + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder >= first) + next_number = number - remainder + } else if (last < number) { + remainder = mod (last - first, step) + if (remainder == 0) + next_number = max (next_number, last) + else if (last - remainder >= first) + next_number = max (next_number, last - remainder) + } + } + + if (next_number == 0) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# IS_IN_RANGE -- Test number to see if it is in range. + +bool procedure lis_in_range (ranges, number) + +int ranges[ARB] # Range array +int number # Number to be tested against ranges + +int ip, first, last, step + +begin + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) + if (mod (number - first, step) == 0) + return (true) + } + + return (false) +end diff --git a/pkg/xtools/mef/mefget.x b/pkg/xtools/mef/mefget.x new file mode 100644 index 00000000..4860c99e --- /dev/null +++ b/pkg/xtools/mef/mefget.x @@ -0,0 +1,183 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include <pkg/mef.h> + +# MEFGETB -- Get an image header parameter of type boolean. False is returned +# if the parameter cannot be found or if the value is not true. + +bool procedure mefgetb (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +pointer sp, kv, line +int strlen() +bool bval + +errchk mef_findkw + +begin + call smark (sp) + call salloc (kv, LEN_CARD, TY_CHAR) + call salloc (line, LEN_CARD, TY_CHAR) + + call mef_findkw (MEF_HDRP(mef), key, Memc[kv]) + if (strlen(Memc[kv]) != 1) { + call sprintf(Memc[line], LEN_CARD, "Invalid boolean value: '%s'") + call pargstr (Memc[kv]) + call error (0,Memc[line]) + }else + bval = Memc[kv] == 'T' + + call sfree (sp) + return (bval) +end + + +# MEFGETC -- Get an image header parameter of type char. + +char procedure mefgetc (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned +long mefgetl() + +begin + return (mefgetl (mef, key)) +end + + +# MEFGETD -- Get an image header parameter of type double floating. If the +# named parameter is a standard parameter return the value directly, +# else scan the user area for the named parameter and decode the value. + +double procedure mefgetd (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +int ip +double dval +pointer sp, sval +int ctod() +errchk syserrs, mefgstr + +begin + call smark (sp) + call salloc (sval, SZ_LINE, TY_CHAR) + + ip = 1 + call mefgstr (mef, key, Memc[sval], SZ_LINE) + if(Memc[sval]==EOS) + call syserrs (SYS_IDBKEYNF, key) + if (ctod (Memc[sval], ip, dval) == 0) + call syserrs (SYS_IDBTYPE, key) + + call sfree (sp) + return (dval) +end + + +# MEFGETI -- Get an image header parameter of type integer. + +int procedure mefgeti (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +long lval, mefgetl() +errchk mefgetl + +begin + lval = mefgetl (mef, key) + if (IS_INDEFL(lval)) + return (INDEFI) + else + return (lval) +end + + +# MEFGETL -- Get an image header parameter of type long integer. + +long procedure mefgetl (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +double dval, mefgetd() +errchk mefgetd + +begin + dval = mefgetd (mef, key) + if (IS_INDEFD(dval)) + return (INDEFL) + else + return (nint (dval)) +end + + +# MEFGETR -- Get an image header parameter of type real. + +real procedure mefgetr (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +double dval, mefgetd() +errchk mefgetd + +begin + dval = mefgetd (mef, key) + if (IS_INDEFD(dval)) + return (INDEFR) + else + return (dval) +end + + +# MEFGETS -- Get an image header parameter of type short integer. + +short procedure mefgets (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +long lval, mefgetl() +errchk mefgetl + +begin + lval = mefgetl (mef, key) + if (IS_INDEFL(lval)) + return (INDEFS) + else + return (lval) +end + + +# MEFGSTR -- Get an image header parameter of type string. If the named +# parameter is a standard parameter return the value directly, else scan +# the user area for the named parameter and decode the value. + +procedure mefgstr (mef, key, outstr, maxch) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned +char outstr[ARB] # output string to receive parameter value +int maxch + +pointer sp, kv + +begin + call smark (sp) + call salloc (kv, LEN_CARD, TY_CHAR) + + # Find the record. + iferr (call mef_findkw (MEF_HDRP(mef), key, Memc[kv])) + Memc[kv] = EOS + + call strcpy (Memc[kv], outstr, min (maxch, LEN_CARD)) + + call sfree (sp) +end diff --git a/pkg/xtools/mef/mefgnbc.x b/pkg/xtools/mef/mefgnbc.x new file mode 100644 index 00000000..2d370893 --- /dev/null +++ b/pkg/xtools/mef/mefgnbc.x @@ -0,0 +1,55 @@ +include <pkg/mef.h> + +# MEF_GNBC -- Get the Number of Blank Cards in a FITS header pointed by +# mef. This is the number of cards available to insert before an expantion by +# one block is required. If the header has not being read and EOF (-2) is +# returned. + +int procedure mef_gnbc (mef) + +pointer mef + +int len, hd, ip, nbc, hsize, k, ncards +int strlen(), strncmp() + +begin + if (MEF_HDRP(mef) == NULL) + return (EOF) + + hd = MEF_HDRP(mef) + len = strlen(Memc[hd]) + + # Go to the end of buffer and get last line + + ip = hd + MEF_HSIZE(mef) - LEN_CARDNL + + # See if line is blank + + nbc = 0 + while (ip > 0) { + do k = 0, LEN_CARD-1 + if (Memc[ip+k] != ' ') + break + + if (k != LEN_CARD && k != 0) # blank keyw card + break + else if (k == 0) { + if (strncmp ("END ", Memc[ip], 8) == 0) { + ip = ip - LEN_CARDNL + next + } else + break + } else + nbc = nbc + 1 + ip = ip - LEN_CARDNL + } + + hsize = MEF_HSIZE(mef) + ncards = (hsize + 80)/81 + + ncards = ((ncards + 35)/36)*36 - ncards + nbc = nbc + ncards + + return (nbc) +end + diff --git a/pkg/xtools/mef/mefgval.x b/pkg/xtools/mef/mefgval.x new file mode 100644 index 00000000..aa481a2a --- /dev/null +++ b/pkg/xtools/mef/mefgval.x @@ -0,0 +1,182 @@ +include <ctype.h> +include <pkg/mef.h> + + +# MEFGVAL.X -- Set of routines to decode the value of a FITS keyword given +# the whole card. + + +# MEF_GVALI -- Return the integer value of a FITS encoded card. + +procedure mef_gvali (card, ival) + +char card[ARB] #I card to be decoded +int ival #O receives integer value + +int ip, ctoi() +char sval[MEF_SZVALSTR] + +begin + call mef_gvalt (card, sval, MEF_SZVALSTR) + ip = 1 + if (ctoi (sval, ip, ival) <= 0) + ival = 0 +end + + +# MEF_GVALR -- Return the real value of a FITS encoded card. + +procedure mef_gvalr (card, rval) + +char card[ARB] #I card to be decoded +real rval #O receives integer value + +int ip, ctor() +char sval[MEF_SZVALSTR] + +begin + call mef_gvalt (card, sval, MEF_SZVALSTR) + ip = 1 + if (ctor (sval, ip, rval) <= 0) + rval = 0.0 +end + + +# MEF_GVALD -- Return the double value of a FITS encoded card. + +procedure mef_gvald (card, dval) + +char card[ARB] #I card to be decoded +double dval #O receives integer value + +int ip, ctod() +char sval[MEF_SZVALSTR] + +begin + call mef_gvalt (card, sval, MEF_SZVALSTR) + ip = 1 + if (ctod (sval, ip, dval) <= 0) + dval = 0.0 +end + + +# MEF_GVALB -- Return the boolean/integer value of a FITS encoded card. + +procedure mef_gvalb (card, bval) + +char card[ARB] #I card to be decoded +int bval #O receives YES/NO + +char sval[MEF_SZVALSTR] + +begin + call mef_gvalt (card, sval, MEF_SZVALSTR) + if (sval[1] == 'T') + bval = YES + else + bval = NO +end + + +# MEF_GVALT -- Get the string value of a FITS encoded card. Strip leading +# and trailing whitespace and any quotes. + +procedure mef_gvalt (card, outstr, maxch) + +char card[ARB] #I FITS card to be decoded +char outstr[ARB] #O output string to receive parameter value +int maxch #I length of outstr + +int ip, op +int ctowrd(), strlen() + +begin + ip = FITS_STARTVALUE + if (ctowrd (card, ip, outstr, maxch) > 0) { + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end + + +# MEF_GETCMT -- Get the comment field of a FITS encoded card. + +procedure mef_getcmt (card, comment, maxch) + +char card[ARB] #I FITS card to be decoded +char comment[ARB] #O output string to receive comment +int maxch #I max chars out + +int ip, op +int lastch + +begin + # Find the slash which marks the beginning of the comment field. + ip = FITS_ENDVALUE + 1 + while (card[ip] != EOS && card[ip] != '\n' && card[ip] != '/') + ip = ip + 1 + + # Copy the comment to the output string, omitting the /, any + # trailing blanks, and the newline. + + lastch = 0 + do op = 1, maxch { + if (card[ip] == EOS) + break + ip = ip + 1 + comment[op] = card[ip] + if (card[ip] > ' ') + lastch = op + } + comment[lastch+1] = EOS +end + + +# MEF_GLTM -- Procedure to convert an input time stream with hh:mm:ss +# and date stream dd/mm/yy into seconds from jan 1st 1980. + +procedure mef_gltm (time, date, limtime) + +char time[ARB] #I time +char date[ARB] #I date +int limtime #O seconds + +int hr,mn,sec,days,month,year, ip, iy, days_per_year, ctoi(),i +int month_to_days[12], adays + +data month_to_days / 0,31,59,90,120,151,181,212,243,273,304,334/ + +begin + ip = 1 + ip = ctoi (time, ip, hr) + ip = 1 + ip = ctoi (time[4], ip, mn) + ip = 1 + ip = ctoi (time[7], ip, sec) + + sec = sec + mn * 60 + hr * 3600 + + ip = 1 + ip = ctoi (date, ip, days) + ip = 1 + ip = ctoi (date[4], ip, month) + ip = 1 + ip = ctoi (date[7], ip, year) + + days_per_year = 0 + + iy = year + 1900 + do i = 1, iy - 1980 + days_per_year = days_per_year + 365 + + adays= (year-80)/4 + if (month > 2) adays=adays+1 + + days = adays + days-1 + days_per_year + month_to_days[month] + + limtime = sec + days * 86400 +end diff --git a/pkg/xtools/mef/mefkfind.x b/pkg/xtools/mef/mefkfind.x new file mode 100644 index 00000000..bfcf393b --- /dev/null +++ b/pkg/xtools/mef/mefkfind.x @@ -0,0 +1,75 @@ +include <syserr.h> +include <pkg/mef.h> + +# MEF_FINDKW -- Search the header database for a particular keyword +# and get its value. An error is returned if the keyword is not found. + +procedure mef_findkw (hdrp, key, keywval) + +pointer hdrp #I pointer to header buffer +char key[ARB] #I Keyword name +char keywval[ARB] #O string value + +pointer sp, ukey, lkey, ip +int nchars, lch, uch, ch, i +int gstrcpy() + +errchk syserrs + +begin + call smark (sp) + call salloc (ukey, SZ_KEYWORD, TY_CHAR) + call salloc (lkey, SZ_KEYWORD, TY_CHAR) + + # Prepare U/L FITS keywords, truncated to 8 chars. + nchars = gstrcpy (key, Memc[lkey], SZ_KEYWORD) + call strlwr (Memc[lkey]) + nchars = gstrcpy (key, Memc[ukey], SZ_KEYWORD) + call strupr (Memc[ukey]) + + # Search for the FIRST occurrence of a record with the given key. + + # Fixed length (80 character), newline terminated records, EOS + # terminated record group. + + # Simple fast search, fixed length records. Case insensitive + # keyword match. + + lch = Memc[lkey] + uch = Memc[ukey] + + for (ip=hdrp; Memc[ip] != EOS; ip=ip+LEN_CARDNL) { + ch = Memc[ip] + if (ch == EOS) + break + else if (ch != lch && ch != uch) + next + else { + # Abbreviations are not permitted. + ch = Memc[ip+nchars] + if (ch != ' ' && ch != '=') + next + } + + # First char matches; check rest of string. + do i = 1, nchars-1 { + ch = Memc[ip+i] + if (ch != Memc[lkey+i] && ch != Memc[ukey+i]) { + ch = 0 + break + } + } + + if (ch != 0) { + #Copy card starting at ip + call mef_gvalt (Memc[ip], keywval, MEF_SZVALSTR) + call sfree (sp) + return + } + } + + # Keyword not found + call syserrs (SYS_IDBKEYNF, key) + + call sfree (sp) +end diff --git a/pkg/xtools/mef/mefksection.x b/pkg/xtools/mef/mefksection.x new file mode 100644 index 00000000..e6a44b7b --- /dev/null +++ b/pkg/xtools/mef/mefksection.x @@ -0,0 +1,174 @@ +include <ctotok.h> +include <lexnum.h> +include <pkg/mef.h> + +define KS_EXTNAME 1 +define KS_EXTVER 2 + +# MEF_KSECTION -- Procedure to parse and analyze a string of the form +# +# "(extname=)name,(extver=)23" +# +# The numeric field is position depend if it does not have 'extver'. + +procedure mef_ksection (ksection, extname, extver) + +char ksection[ARB] #I String with kernel section +char extname[ARB] #O Extname +int extver #O Extver + +int ctotok(),ip, jp, nident, nexpr +int junk, nch, lexnum(), ty, token, ival +char outstr[LEN_CARD] +char identif[LEN_CARD] +int lex_type, mef_klex(), ctoi() + +begin + + extname[1] = EOS + extver = INDEFL + ip = 1 + nident = 0 + nexpr = 0 + identif[1] = EOS + + repeat { + # Advance to the next keyword. + token = ctotok (ksection, ip, outstr, LEN_CARD) + + switch (token) { + case TOK_EOS: + break + case TOK_NEWLINE: + break + case TOK_NUMBER: + if (nexpr != 1) + call error(13, + "Numeric value only allow as second term in ksection") + jp = 1 + ty = lexnum (outstr, jp, nch) + if (ty != LEX_DECIMAL) + call error(13, "Number is not decimal") + jp = 1 + junk = ctoi(outstr, jp, ival) + extver = ival + nexpr = nexpr + 1 + case TOK_PUNCTUATION: + if (outstr[1] == ',' && identif[1] == EOS) + call error(13,"syntax error in kernel section") + case TOK_STRING: + if (nexpr != 0) + call error(13, + "String value only allow as first term in ksection") + + call strcpy (outstr, extname, LEN_CARD) + nexpr = nexpr + 1 + case TOK_IDENTIFIER: + nident = nident + 1 + call strcpy(outstr, identif, LEN_CARD] + call strlwr(outstr) + lex_type = mef_klex (outstr) + # See if it is a reserved keyword. + jp = ip + # look for =, + or - + if (lex_type > 0) { + # Now see if of the type lex=<value> or lex+/- + if (ctotok (ksection, ip, outstr, LEN_CARD) == + TOK_OPERATOR) { + if (outstr[1] == '=' ) { + token = ctotok (ksection, ip, outstr, LEN_CARD) + if (token != TOK_IDENTIFIER && + token != TOK_STRING && + token != TOK_NUMBER) + call error(13, + "syntax error in kernel section") + else + call mef_kvalue(outstr, lex_type, + extname, extver) + } else + ip = jp + } + } else { + if (nexpr == 0) + call strcpy (identif, extname, LEN_CARD) + else { + call error(13, + "String value only allow as first term in ksection") + } + } + nexpr = nexpr + 1 + default: + call error (13, "Syntax error in ksection") + } + } +end + + +# MEF_KLEX -- Returns the lexival value of a parameter in string. + +int procedure mef_klex (outstr) + +char outstr[ARB] #I string + +int len, strlen(), strncmp() +char tmp[LEN_CARD] + +begin + len = strlen(outstr) + # See if it is extname or extversion + if (strncmp (outstr, "ext", 3) == 0 && len < 8 ) { + if (len == 3) + call error(13, "'ext' is ambiguous in ksection") + call strcpy ("name", tmp, 4) + if (strncmp(outstr[4], tmp, len-3) == 0) + return (KS_EXTNAME) + else { + call strcpy ("ver", tmp, 3) + if (strncmp(outstr[4], tmp, len-3) == 0) + return (KS_EXTVER) + } + } + + return (0) # Is a value + +end + + +define ERROR -2 +# MEF_KVALUE -- Get the value from a string of extname and extver. + +procedure mef_kvalue(outstr, lex_type, extname, extver) + +char outstr[ARB] #I Input string +int lex_type #I Type of value +char extname[ARB] #O Extname +int extver #O Extver + +int ty, lexnum(), ip, ival, ctoi(), nch, junk +int strcmp() + +begin + call strlwr(outstr) + if (strcmp (outstr, "yes") == 0) + ival = YES + else if (strcmp (outstr, "no") == 0) + ival = NO + else + ival = ERROR + + switch (lex_type) { + case KS_EXTNAME: + call strcpy (outstr, extname, LEN_CARD) + case KS_EXTVER: + ip = 1 + ty = lexnum (outstr, ip, nch) + if (ty != LEX_DECIMAL) + call error(13, "Number is not a decimal") + ip = 1 + junk = ctoi(outstr, ip, ival) + extver = ival + default: + call error(13, "Syntax error in ksection") + + } +end diff --git a/pkg/xtools/mef/mefldhdr.x b/pkg/xtools/mef/mefldhdr.x new file mode 100644 index 00000000..c13d7802 --- /dev/null +++ b/pkg/xtools/mef/mefldhdr.x @@ -0,0 +1,118 @@ +include <error.h> +include <mach.h> +include <ctype.h> +include <mii.h> +include <pkg/mef.h> + +# MEF_LOAD_HEADER -- Load a FITS header from a file descriptor into a +# spool file. + +int procedure mef_load_header (mef, spool, group) + +pointer mef #I FITS descriptor +int spool #I spool output file descriptor +int group #I Currrent group + +pointer lbuf, sp, fb +int nchars, index, ncards, pcount, in +int mef_read_card(), mef_kctype() +int note() + +errchk mef_read_card +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (fb, FITS_BLOCK_BYTES, TY_CHAR) + + MEF_EXTNAME(mef) = EOS + MEF_EXTVER(mef) = INDEFL + + in = MEF_FD(mef) + MEF_HOFF(mef) = note(in) + + # Read successive lines of the FITS header. + pcount = 0 + ncards = 0 + repeat { + # Get the next input line. + nchars = mef_read_card (in, Memc[fb], Memc[lbuf], ncards) + if (nchars == EOF) { + call close (spool) + return (EOF) + } + ncards = ncards + 1 + # A FITS header card already has 80 chars, just add the newline. + Memc[lbuf+LEN_CARD] = '\n' + Memc[lbuf+LEN_CARD+1] = EOS + call putline (spool, Memc[lbuf]) + + # Process the header card. + switch (mef_kctype (Memc[lbuf], index)) { + case END: + MEF_HSIZE(mef) = ncards*LEN_CARDNL + break + case SIMPLE: + call strcpy ("SIMPLE", MEF_EXTTYPE(mef), SZ_EXTTYPE) + case XTENSION: + call mef_gvalt (Memc[lbuf], MEF_EXTTYPE(mef), SZ_EXTTYPE) + case EXTNAME: + call mef_gvalt (Memc[lbuf], MEF_EXTNAME(mef), LEN_CARD) + case EXTVER: + call mef_gvali (Memc[lbuf], MEF_EXTVER(mef)) + case PCOUNT: + call mef_gvali (Memc[lbuf], pcount) + MEF_PCOUNT(mef) = pcount + case BITPIX: + call mef_gvali (Memc[lbuf], MEF_BITPIX(mef)) + case NAXIS: + call mef_gvali (Memc[lbuf], MEF_NDIM(mef)) + case NAXISN: + call mef_gvali (Memc[lbuf], MEF_NAXIS(mef,index)) + case OBJECT: + call mef_gvalt (Memc[lbuf], MEF_OBJECT(mef), MEF_SZVALSTR) + default: + if (ncards == 1) { + call sprintf(Memc[lbuf], SZ_LINE, + "Header does not start with SIMPLE nor XTENSION: %s[%d]") + call pargstr(MEF_FNAME(mef)) + call pargi(group) + call error (13, Memc[lbuf]) + } + } + } + + call sfree (sp) + return (OK) +end + + +# MEF_GET_CARD -- Read a FITS header card. + +int procedure mef_read_card (fd, ibuf, obuf, ncards) + +int fd #I Input file descriptor +char ibuf[ARB] #I input buffer +char obuf[ARB] #O Output buffer +int ncards #I ncards read so far + +int ip, nchars_read +int read() +errchk read + +begin + # We read one FITS block first, read card from it until 36 + # cards have been processed, where we read again. + + if (mod (ncards, 36) == 0) { + nchars_read = read (fd, ibuf, FITS_BLKSZ_CHAR) + if (nchars_read == EOF) + return (EOF) + call miiupk (ibuf, ibuf, FITS_BLOCK_BYTES, MII_BYTE, TY_CHAR) + ip = 1 + } + + call amovc (ibuf[ip], obuf, LEN_CARD) + ip = ip + LEN_CARD + + return (LEN_CARD) +end diff --git a/pkg/xtools/mef/mefopen.x b/pkg/xtools/mef/mefopen.x new file mode 100644 index 00000000..a7a6529d --- /dev/null +++ b/pkg/xtools/mef/mefopen.x @@ -0,0 +1,93 @@ +include <pkg/mef.h> + +# MEFOPEN --- Open a FITS extension, it can be the Primary or extension +# unit, file.fits[0] for the PU or file.fits[extn] for the +# Extension Unit. +# +# filename.ext[abs#][extname,extver] +# +# The absolute extension number (abs#) convention is zero for +# the Primary Unit. +# + + +# MEF_OPEN -- Open a FITS Unit from a file and returns its characteristics. + +pointer procedure mef_open (fitsfile, acmode, oldp) + +char fitsfile[ARB] #I Input FITS filename +int acmode #I access mode +pointer oldp #I Old Fits pointer or header size + +pointer sp, ksec, section, mef +int group, clsize, open() + +begin + call smark (sp) + call salloc (ksec, LEN_CARD, TY_CHAR) + call salloc (section, LEN_CARD, TY_CHAR) + + call calloc (mef, LEN_MEF, TY_STRUCT) + + MEF_ACMODE(mef) = acmode + + # Get filename components + call imparse (fitsfile, MEF_FNAME(mef), SZ_FNAME, Memc[ksec], + LEN_CARD, Memc[section], LEN_CARD, group, clsize) + + # Check if file has an extension and exists. + call mef_file_access (MEF_FNAME(mef), acmode) + + if (Memc[section] != EOS) + call error(13, "mefopen: Image sections not allowed") + + MEF_FD(mef) = open (MEF_FNAME(mef), acmode, BINARY_FILE) + MEF_ENUMBER(mef) = group + MEF_CGROUP(mef) = -1 + MEF_KEEPXT(mef) = NO + + call sfree (sp) + return(mef) +end + + +# MEF_FILE_ACCESS -- Check that file exists if READ* mode is given. Mainly we +# want to check if there is an extension 'fits'. If file was given with no +# extension, append .fits and see if exists. + +procedure mef_file_access (fname, acmode) + +char fname[ARB] +int acmode + +pointer sp, fext, fn +int len, fnextn(), access(), strncmp() +begin + if (acmode == NEW_FILE || acmode == NEW_COPY) + return + + call smark (sp) + call salloc (fext, SZ_FNAME, TY_CHAR) + call salloc (fn, SZ_FNAME, TY_CHAR) + + call strcpy (fname, Memc[fn], SZ_FNAME) + + len = fnextn (Memc[fn], Memc[fext], SZ_FNAME) + + if (strncmp("fits", Memc[fext], 4) == 0) + return + + # See if file exists with no extension + if (access(fname, 0, 0) == YES) + return + else { + call strcat( ".fits", Memc[fn], SZ_FNAME) + if (access(Memc[fn], 0, 0) == YES) { + call strcpy (Memc[fn], fname, SZ_FNAME) + return + } + } + + call sfree(sp) + +end diff --git a/pkg/xtools/mef/mefrdhdr.x b/pkg/xtools/mef/mefrdhdr.x new file mode 100644 index 00000000..a8ac45e8 --- /dev/null +++ b/pkg/xtools/mef/mefrdhdr.x @@ -0,0 +1,397 @@ +include <error.h> +include <mach.h> +include <ctype.h> +include <fset.h> +include <pkg/mef.h> + +# MEFRDHR.X -- Routines to read FITS header units. +# +# eof|stat = mef_rdhdr (mef, group, extname, extver) +# mef_skip_data_unit (mef) +# totpix = mef_totpix (mef) +# eof|stat = mef_rdhdr_gn (mef,gn) +# eof|stat = mef_rdhdr_exnv (mef,extname, extver) + + +# MEF_RDHR -- Read FITS header on a mef file that matches EXTNAME/EXTVER or +# GROUP number. If both are specified, the former takes procedence. + +int procedure mef_rdhdr (mef, group, extname, extver) + +pointer mef #I Mef descriptor +int group #I Group number to read +char extname[ARB] #I Extname to read +int extver #I Extver to read + +int open(),in, cur_extn, note(), gnum +int spool +bool extnv, read_next_group +int mef_load_header(), mef_pixtype() +bool mef_cmp_extnv +errchk open, read, mef_load_header + +begin + if (group == MEF_CGROUP(mef)) + return (group) + + gnum = group + if (MEF_FD(mef) == NULL) { + MEF_FD(mef) = open (MEF_FNAME(mef), READ_ONLY, BINARY_FILE) + MEF_ENUMBER(mef) = -1 + MEF_CGROUP(mef) = -1 + } + MEF_SKDATA(mef) = NO + + in = MEF_FD(mef) + + extnv = extname[1] != EOS || extver != INDEFL + spool = open ("spool", NEW_FILE, SPOOL_FILE) + + if (gnum == -1 || extnv) + gnum = 0 + + cur_extn = MEF_CGROUP(mef) + read_next_group = true + + repeat { + # If we need to read the next group + if (read_next_group) { + + cur_extn = cur_extn+1 + + # See if this extension contains the correct + # extname/extver values. + + call fseti (spool, F_CANCEL, YES) + if (mef_load_header (mef, spool, cur_extn) == EOF) { + call close (spool) + return (EOF) + } + + # We read the header already, marked the spot. + MEF_POFF(mef) = note(in) + + if (extnv) { + read_next_group = mef_cmp_extnv (mef, extname, extver) + } else { + if (gnum == cur_extn) + read_next_group = false + } + call mef_skip_data_unit (mef) + next + + } else { # This is the group we want + if (MEF_HDRP(mef) != NULL) + call mfree (MEF_HDRP(mef), TY_CHAR) + + call mef_cp_spool (spool, mef) + MEF_CGROUP(mef) = cur_extn + + # To indicate that data has been skipped. + MEF_SKDATA(mef) = YES + break + } + } + call close (spool) + MEF_DATATYPE(mef) = mef_pixtype(mef) + return (cur_extn) +end + +int procedure mef_pixtype (mef) +pointer mef, hdrp +bool bfloat, lscale, lzero +bool fxf_fpl_equald() +int i, impixtype, ctod(), ip +double bscale, bzero +char sval[LEN_CARD] + +begin + hdrp= MEF_HDRP(mef) + bscale = 1.0d0 + ip=1 + ifnoerr (call mef_findkw (hdrp, "BSCALE", sval)) + i = ctod(sval,ip,bscale) + bzero = 0.0d0 + ip=1 + ifnoerr (call mef_findkw (hdrp, "BZERO", sval)) + i = ctod(sval,ip,bzero) + + lscale = fxf_fpl_equald (1.0d0, bscale, 1) + lzero = fxf_fpl_equald (0.0d0, bzero, 1) + + # Determine if scaling is necessary. + bfloat = (!lscale || !lzero) + + switch (MEF_BITPIX(mef)) { + case 8: + if (bfloat) + impixtype = TY_REAL + else + impixtype = TY_SHORT # convert from byte to short + case 16: + if (bfloat) { + impixtype = TY_REAL + } else + impixtype = TY_SHORT + + if (lscale && fxf_fpl_equald (32768.0d0, bzero, 4)) { + impixtype = TY_USHORT + } + case 32: + if (bfloat) + impixtype = TY_REAL + else + impixtype = TY_INT + case -32: + impixtype = TY_REAL + case -64: + impixtype = TY_DOUBLE + default: + impixtype = ERR + } + + return(impixtype) + +end + +# MEF_CMP_EXTNV -- Compare the EXTNAME and EXTVER header values with the +# ones passed as arguments. Return false if matched. + +bool procedure mef_cmp_extnv (mef, extname, extver) +pointer mef +char extname[ARB] #I extname value +int extver #I extver value + +int mef_strcmp_lwr() +bool bxtn, bxtv, bval, bxtn_eq, bxtv_eq + +begin + bxtn = extname[1] != EOS + bxtv = extver != INDEFL + + if (bxtn) + bxtn_eq = (mef_strcmp_lwr(MEF_EXTNAME(mef), extname) == 0) + if (bxtv) + bxtv_eq = (MEF_EXTVER(mef) == extver) + + if (bxtn && bxtv) + # Both EXTNAME and EXTVER are defined. + bval = bxtn_eq && bxtv_eq + else if (bxtn && !bxtv) + # Only EXTNAME is defined. + bval = bxtn_eq + else if (!bxtn && bxtv) + # Only EXTVER is defined. + bval = bxtv_eq + else + bval = false + + return (!bval) +end + +# MEF_SKIP_DATA_UNIT -- Skip data unit. The file is already position at the +# end of the last header block. + +procedure mef_skip_data_unit (mef) + +pointer mef #I Input mef descriptor + +int in, ndim, off, note(), mef_totpix() +errchk seek + +begin + # See if data portion has already been skipped. + if (MEF_SKDATA(mef) == YES) + return + + in = MEF_FD(mef) + ndim = MEF_NDIM (mef) + if (ndim > 0 || MEF_PCOUNT(mef) > 0) { + # Skip to the beginning of next extension + off = note(in) + if (off == EOF) + return + off = off + mef_totpix(mef) + call seek (in, off) + } +end + + +# MEF_TOTPIX -- Returns the number of pixels in the data area in units +# of chars. + +int procedure mef_totpix (mef) + +pointer mef #I Mef descriptor + +int ndim, totpix, i, bitpix + +begin + ndim = MEF_NDIM (mef) + if (ndim == 0 && MEF_PCOUNT(mef) <= 0) + return (0) + + if (ndim == 0) + totpix = 0 + else { + totpix = MEF_NAXIS(mef,1) + do i = 2, ndim + totpix = totpix * MEF_NAXIS(mef,i) + } + bitpix = abs(MEF_BITPIX(mef)) + + # If PCOUNT is not zero, add it to totpix + totpix = MEF_PCOUNT(mef) + totpix + + if (bitpix <= NBITS_BYTE) + totpix = (totpix + 1) / SZB_CHAR + else + totpix = totpix * (bitpix / (SZB_CHAR * NBITS_BYTE)) + + # Set the number of characters in multiple of 1440. + totpix = ((totpix + 1439)/1440) * 1440 + return (totpix) +end + + +# MEF_STRCMP_LWR -- Compare 2 strings in lower case + +int procedure mef_strcmp_lwr (s1, s2) + +char s1[ARB], s2[ARB] + +pointer sp, l1, l2 +int strcmp(), istat + +begin + call smark(sp) + call salloc (l1, SZ_FNAME, TY_CHAR) + call salloc (l2, SZ_FNAME, TY_CHAR) + + call strcpy (s1, Memc[l1], SZ_FNAME) + call strcpy (s2, Memc[l2], SZ_FNAME) + call strlwr(Memc[l1]) + call strlwr(Memc[l2]) + istat = strcmp (Memc[l1], Memc[l2]) + + call sfree(sp) + return (istat) +end + + +# MEF_KCTYPE -- Find the type of card that is based on the keyword name. + +int procedure mef_kctype (card, index) + +char card[ARB] #I FITS card +int index #O index value + +int strncmp() + +begin + if (strncmp (card, "SIMPLE ", 8) == 0) + return (SIMPLE) + if (strncmp (card, "NAXIS", 5) == 0) { + if (card[6] == ' ') { + call mef_gvali (card, index) + return (NAXIS) + } else if (IS_DIGIT(card[6])) { + index = TO_INTEG(card[6]) + return (NAXISN) # NAXISn + } + } + if (strncmp (card, "BITPIX ", 8) == 0) + return (BITPIX) + if (strncmp (card, "EXTNAME ", 8) == 0) + return (EXTNAME) + if (strncmp (card, "EXTVER ", 8) == 0) + return (EXTVER) + if (strncmp (card, "EXTEND ", 8) == 0) + return (EXTEND) + if (strncmp (card, "PCOUNT ", 8) == 0) + return (PCOUNT) + if (strncmp (card, "FILENAME", 8) == 0) + return (FILENAME) + if (strncmp (card, "INHERIT ", 8) == 0) + return (INHERIT) + if (strncmp (card, "GCOUNT ", 8) == 0) + return (GCOUNT) + if (strncmp (card, "OBJECT ", 8) == 0) + return (OBJECT) + if (strncmp (card, "XTENSION", 8) == 0) + return (XTENSION) + if (strncmp (card, "END ", 8) == 0) + return (END) + + return(ERR) +end + + +# MEF_RDHDR_GN -- Read group based on group number + +int procedure mef_rdhdr_gn (mef,gn) + +pointer mef #I mef descriptor +int gn #I group number to read + +char extname[MEF_SZVALSTR] +int extver +int mef_rdhdr() + +errchk mef_rdhdr + +begin + extname[1] =EOS + extver=INDEFL + return (mef_rdhdr (mef, gn, extname, extver)) +end + + +# MEF_RDHDR_EXNV -- Read group based on the Extname and Extver values + +int procedure mef_rdhdr_exnv (mef,extname, extver) + +pointer mef #I, mef descriptor +char extname[ARB] #I, extname value +int extver #I, extver value +int mef_rdhdr() + +errchk mef_rdhdr + +begin + return (mef_rdhdr (mef, 0, extname, extver)) +end + + +# MEF_CP_SPOOL -- + +procedure mef_cp_spool (spool, mef) + +int spool #I spool file descriptor +pointer mef # + +pointer hdr, lbuf, sp +int fitslen, fstatl, user +int stropen(), getline() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + call seek (spool, BOFL) + fitslen = fstatl (spool, F_FILESIZE) + fitslen = max (fitslen, MEF_HSIZE(mef)) + call malloc (hdr, fitslen, TY_CHAR) + user = stropen (Memc[hdr], fitslen, NEW_FILE) + + # Append the saved FITS cards to saved cache. + while (getline (spool, Memc[lbuf]) != EOF) + call putline (user, Memc[lbuf]) + + call close (user) + call close (spool) + + MEF_HDRP(mef) = hdr + + call sfree(sp) +end diff --git a/pkg/xtools/mef/mefrdhdr.x_save b/pkg/xtools/mef/mefrdhdr.x_save new file mode 100644 index 00000000..a46d5d04 --- /dev/null +++ b/pkg/xtools/mef/mefrdhdr.x_save @@ -0,0 +1,529 @@ +include <error.h> +include <mach.h> +include <ctype.h> +include <fset.h> +include <mef.h> + +# MEFRDHR.X -- Routines to read FITS header units. +# +# mef_rdhdr (mef, group, extname, extver) +# mef_rdblk (in, spp_buf) +# mef_skip_data_unit (mef) +# totpix = mef_totpix (mef) +# mef_rd2end (mef, read_next_group) +# mef_rdhdr_gn (mef,gn) +# mef_rdhdr_exnv (mef,extname, extver) + + +# MEF_RDHR -- Read FITS header on a mef file that matches EXTNAME/EXTVER or +# GROUP number. If both are specified, the former takes procedence. + +procedure mef_rdhdr (mef, group, extname, extver) + +pointer mef #I Mef descriptor +int group #I Group number to read +char extname[ARB] #I Extname to read +int extver #I Extver to read + +int open(),in, cur_extn, note(), gnum +int spool +char spp_buf[FITS_BLKSZ_NL] +bool extnv, end_card, read_next_group, mef_rd1st() +bool mef_cmp_extnv +errchk open, read, mef_rd1st, mef_load_header + +begin + if (group == MEF_CGROUP(mef)) + return + + gnum = group + if (MEF_FD(mef) == NULL) { + MEF_FD(mef) = open (MEF_FNAME(mef), READ_ONLY, BINARY_FILE) + MEF_ENUMBER(mef) = -1 + MEF_CGROUP(mef) = -1 + } + MEF_SKDATA(mef) = NO + + in = MEF_FD(mef) + + extnv = extname[1] != EOS || extver != INDEFL + if (extnv) + spool = open ("spool", NEW_FILE, SPOOL_FILE) + + if (gnum == -1 || extnv) + gnum = 0 +# else if (gnum != -1 && extnv) +# gnum = -1 # EXTNAME/EXTVER takes precedence + + cur_extn = MEF_CGROUP(mef) +# if (cur_extn < 0) +# cur_extn = -1 # Ready to read PHU + read_next_group = true + + repeat { + # If we need to read the next group + if (read_next_group) { + # Read 1st block + cur_extn = cur_extn+1 + + # See if this extension contains the correct + # extname/extver values. + + if (extnv) { + end_card = true + # We are not sure if extname or extver are in the + # 1st block. + call fseti (spool, F_CANCEL, YES) + call mef_load_header (mef, spool) +# iferr (call mef_load_header (mef, spool)) { +# call erract(EA_WARN) +# } + + read_next_group = mef_cmp_extnv (mef, extname, extver) + MEF_POFF(mef) = note(in) + call mef_skip_data_unit (mef) + next + } else { + end_card = mef_rd1st (mef, spp_buf) + if (gnum == cur_extn) + read_next_group = false + } + + if (read_next_group) { + if (!end_card) + call mef_rd2end (mef, read_next_group) + call mef_skip_data_unit (mef) + } + } else { # This is the group we want + if (MEF_HDRP(mef) != NULL) + call mfree (MEF_HDRP(mef), TY_CHAR) + if (end_card) { + if (extnv) { + call mef_cp_spool (spool, mef) + cur_extn = cur_extn + 1 + } else { + call malloc (MEF_HDRP(mef), MEF_HSIZE(mef)+1, TY_CHAR) + call amovc (spp_buf, Memc[MEF_HDRP(mef)], MEF_HSIZE(mef)) + Memc[MEF_HDRP(mef)+MEF_HSIZE(mef)] = EOS + } + } else { + call malloc (MEF_HDRP(mef), FITS_BLKSZ_NL, TY_CHAR) + call amovc (spp_buf, Memc[MEF_HDRP(mef)], FITS_BLKSZ_NL) + call mef_rd2end (mef, read_next_group) + } + if (!extnv) { + if (MEF_NDIM(mef) != 0 || MEF_PCOUNT(mef) > 0) + MEF_POFF(mef) = note(in) + else + MEF_POFF(mef) = INDEFL + call mef_skip_data_unit (mef) + } + MEF_CGROUP(mef) = cur_extn + + # To indicate that data has been skipped. + MEF_SKDATA(mef) = YES + + return + } + } +end + + +# MEF_RD1ST -- Handle the 1st FITS header block. +# Return true if the END card is in this 1st block. + +bool procedure mef_rd1st (mef, hbuf) + +pointer mef #I Mef descriptor +char hbuf[ARB] #O Buffer containing the first block of a unit + +int in, k, i, index, mef_kctype() +int strncmp(), note() +pointer sp, errmsg + +errchk mef_rdblk + +begin + in = MEF_FD(mef) + + # Read 1st block. + MEF_HOFF(mef) = note(in) + call mef_rdblk (in, hbuf) + + MEF_EXTNAME(mef) = EOS + MEF_EXTVER(mef) = INDEFL + k = 1 + # Verify FITS header + if (strncmp (hbuf[k], "SIMPLE ", 8) != 0 && + strncmp (hbuf[k], "XTENSION", 8) != 0 ) { + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call sprintf (Memc[errmsg], SZ_LINE, "Extension %s[%d] is not FITS.") + call pargstr(MEF_FNAME(mef)) + call pargi(MEF_CGROUP(mef)) + call error (13, Memc[errmsg]) +# iferr (call error (13, Memc[errmsg])) { +# call sfree (sp) +# call erract (EA_ERROR) +# } + } else { + call mef_gvalt (hbuf[k], MEF_EXTTYPE(mef), MEF_SZVALSTR) + if (strncmp (hbuf[k], "SIMPLE ", 8) == 0) + call strcpy (MEF_FNAME(mef), MEF_EXTTYPE(mef), MEF_SZVALSTR) + } + k = k + LEN_CARDNL + + MEF_PCOUNT(mef) = 0 + + for (i=2; i< 37; i=i+1) { + switch (mef_kctype(hbuf[k], index)) { + case NAXIS: + MEF_NDIM(mef) = index + case NAXISN: + call mef_gvali (hbuf[k], MEF_NAXIS(mef,index)) + case BITPIX: + call mef_gvali (hbuf[k], MEF_BITPIX(mef)) + case EXTNAME: + call mef_gvalt (hbuf[k], MEF_EXTNAME(mef), MEF_SZVALSTR) + case EXTVER: + call mef_gvali (hbuf[k], MEF_EXTVER(mef)) + case PCOUNT: + call mef_gvali (hbuf[k], MEF_PCOUNT(mef)) + case OBJECT: + call mef_gvalt (hbuf[k], MEF_OBJECT(mef), MEF_SZVALSTR) + case END: + MEF_HSIZE(mef) = i*LEN_CARDNL + return(true) + break + default: + ; + } + k = k + LEN_CARDNL + } + return(false) + +end + + +# MEF_RDBLK -- Read one header FITS block from disk and add a newline +# after each fits record (80 chars). + +procedure mef_rdblk (in, spp_buf) + +int in #I File descriptor +char spp_buf[ARB] #O Buffer with header + +char ibuf[FITS_BLKSZ_CHAR] +int nchar, i, read(), k, j +char line[LEN_CARD] + +begin + nchar = read (in, ibuf, FITS_BLKSZ_CHAR) + if (nchar == EOF) + call error(13, "EOF encountered") + + # Unpack the input buffer to spp char with new_line delimited records. + line[LEN_CARDNL] = '\n' + k = 1 + j = 1 + for (i=1; i<37; i=i+1) { + call achtbc(ibuf[k], line, LEN_CARD) + call amovc (line, spp_buf[j], LEN_CARDNL) + k = k + 40 + j = j + LEN_CARDNL + } +end + + +# MEF_CMP_EXTNV -- Compare the EXTNAME and EXTVER header values with the +# ones passed as arguments. Return false if matched. + +bool procedure mef_cmp_extnv (mef, extname, extver) +pointer mef +char extname[ARB] #I extname value +int extver #I extver value + +int mef_strcmp_lwr() +bool bxtn, bxtv, bval, bxtn_eq, bxtv_eq + +begin + bxtn = extname[1] != EOS + bxtv = extver != INDEFL + + if (bxtn) + bxtn_eq = (mef_strcmp_lwr(MEF_EXTNAME(mef), extname) == 0) + if (bxtv) + bxtv_eq = (MEF_EXTVER(mef) == extver) + + if (bxtn && bxtv) + # Both EXTNAME and EXTVER are defined. + bval = bxtn_eq && bxtv_eq + else if (bxtn && !bxtv) + # Only EXTNAME is defined. + bval = bxtn_eq + else if (!bxtn && bxtv) + # Only EXTVER is defined. + bval = bxtv_eq + else + bval = false + + return (!bval) +end + +# MEF_SKIP_DATA_UNIT -- Skip data unit. The file is already position at the +# end of the last header block. + +procedure mef_skip_data_unit (mef) + +pointer mef #I Input mef descriptor + +int in, ndim, off, note(), mef_totpix() +errchk seek + +begin + # See if data portion has already been skipped. + if (MEF_SKDATA(mef) == YES) + return + + in = MEF_FD(mef) + ndim = MEF_NDIM (mef) + if (ndim > 0 || MEF_PCOUNT(mef) > 0) { + # Skip to the beginning of next extension + off = note(in) + if (off == EOF) + return + off = off + mef_totpix(mef) + call seek (in, off) + } +end + + +# MEF_TOTPIX -- Returns the number of pixels in the data area in units +# of chars. + +int procedure mef_totpix (mef) + +pointer mef #I Mef descriptor + +int ndim, totpix, i, bitpix + +begin + ndim = MEF_NDIM (mef) + if (ndim == 0 && MEF_PCOUNT(mef) <= 0) + return (0) + + if (ndim == 0) + totpix = 0 + else { + totpix = MEF_NAXIS(mef,1) + do i = 2, ndim + totpix = totpix * MEF_NAXIS(mef,i) + } + bitpix = abs(MEF_BITPIX(mef)) + + # If PCOUNT is not zero, add it to totpix + totpix = MEF_PCOUNT(mef) + totpix + + if (bitpix <= NBITS_BYTE) + totpix = (totpix + 1) / SZB_CHAR + else + totpix = totpix * (bitpix / (SZB_CHAR * NBITS_BYTE)) + + # Set the number of characters in multiple of 1440. + totpix = ((totpix + 1439)/1440) * 1440 + return (totpix) +end + + +# MEF_RD2END -- Read from block 2 to the end. + +procedure mef_rd2end (mef, read_next_group) + +pointer mef #I mef descriptor +bool read_next_group #I if true, read current header to END + +char hbuf[FITS_BLKSZ_NL] +int in, k,i, nblks, strncmp(), size_last_block, hoffset +errchk mef_rdblk + +begin + in = MEF_FD(mef) + # We need to read the header only. + if (read_next_group) + repeat { + k = 1 + call mef_rdblk (in, hbuf) + for (i=1; i<37; i=i+1) { + if (strncmp (hbuf[k], "END " , 8) == 0) + return + else + k = k + LEN_CARDNL + } + } + + + # This is the requested header, copy to user area. + nblks = 2 + repeat { + k = 1 + call mef_rdblk (in, hbuf) + # Copy the buffer into the user area. + for (i=1; i<37; i=i+1) { + if (strncmp (hbuf[k], "END " , 8) == 0) { + size_last_block = i*LEN_CARDNL + call realloc (MEF_HDRP(mef), FITS_BLKSZ_NL*nblks+1, TY_CHAR) + hoffset = MEF_HDRP(mef)+FITS_BLKSZ_NL*(nblks-1) + call amovc (hbuf, Memc[hoffset], size_last_block) + Memc[hoffset+size_last_block] = EOS + MEF_HSIZE(mef) = (nblks-1)*FITS_BLKSZ_NL + size_last_block + return + } else + k = k + LEN_CARDNL + } + call realloc (MEF_HDRP(mef), FITS_BLKSZ_NL*nblks, TY_CHAR) + hoffset = MEF_HDRP(mef)+FITS_BLKSZ_NL*(nblks-1) + call amovc (hbuf, Memc[hoffset], FITS_BLKSZ_NL) + nblks = nblks + 1 + } +end + + +# MEF_STRCMP_LWR -- Compare 2 strings in lower case + +int procedure mef_strcmp_lwr (s1, s2) + +char s1[ARB], s2[ARB] + +pointer sp, l1, l2 +int strcmp(), istat + +begin + call smark(sp) + call salloc (l1, SZ_FNAME, TY_CHAR) + call salloc (l2, SZ_FNAME, TY_CHAR) + + call strcpy (s1, Memc[l1], SZ_FNAME) + call strcpy (s2, Memc[l2], SZ_FNAME) + call strlwr(Memc[l1]) + call strlwr(Memc[l2]) + istat = strcmp (Memc[l1], Memc[l2]) + + call sfree(sp) + return (istat) +end + + +# MEF_KCTYPE -- Find the type of card that is based on the keyword name. + +int procedure mef_kctype (card, index) + +char card[ARB] #I FITS card +int index #O index value + +int strncmp() + +begin + if (strncmp (card, "SIMPLE ", 8) == 0) + return (SIMPLE) + if (strncmp (card, "NAXIS", 5) == 0) { + if (card[6] == ' ') { + call mef_gvali (card, index) + return (NAXIS) + } else if (IS_DIGIT(card[6])) { + index = TO_INTEG(card[6]) + return (NAXISN) # NAXISn + } + } + if (strncmp (card, "BITPIX ", 8) == 0) + return (BITPIX) + if (strncmp (card, "EXTNAME ", 8) == 0) + return (EXTNAME) + if (strncmp (card, "EXTVER ", 8) == 0) + return (EXTVER) + if (strncmp (card, "EXTEND ", 8) == 0) + return (EXTEND) + if (strncmp (card, "PCOUNT ", 8) == 0) + return (PCOUNT) + if (strncmp (card, "FILENAME", 8) == 0) + return (FILENAME) + if (strncmp (card, "INHERIT ", 8) == 0) + return (INHERIT) + if (strncmp (card, "GCOUNT ", 8) == 0) + return (GCOUNT) + if (strncmp (card, "OBJECT ", 8) == 0) + return (OBJECT) + if (strncmp (card, "XTENSION", 8) == 0) + return (XTENSION) + if (strncmp (card, "END ", 8) == 0) + return (END) + + return(ERR) +end + + +# MEF_RDHDR_GN -- Read group based on group number + +procedure mef_rdhdr_gn (mef,gn) + +pointer mef #I mef descriptor +int gn #I group number to read + +char extname[MEF_SZVALSTR] +int extver + +errchk mef_rdhdr + +begin + extname[1] =EOS + extver=INDEFL + call mef_rdhdr (mef, gn, extname, extver) +end + + +# MEF_RDHDR_EXNV -- Read group based on the Extname and Extver values + +procedure mef_rdhdr_exnv (mef,extname, extver) + +pointer mef #I, mef descriptor +char extname[ARB] #I, extname value +int extver #I, extver value + +errchk mef_rdhdr + +begin + call mef_rdhdr (mef, 0, extname, extver) +end + + +# MEF_CP_SPOOL -- + +procedure mef_cp_spool (spool, mef) + +int spool #I spool file descriptor +pointer mef # + +pointer hdr, lbuf, sp +int fitslen, fstatl, user +int stropen(), getline() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + call seek (spool, BOFL) + fitslen = fstatl (spool, F_FILESIZE) + fitslen = max (fitslen, MEF_HSIZE(mef)) + call malloc (hdr, fitslen, TY_CHAR) + user = stropen (Memc[hdr], fitslen, NEW_FILE) + + # Append the saved FITS cards to saved cache. + while (getline (spool, Memc[lbuf]) != EOF) + call putline (user, Memc[lbuf]) + + call close (user) + call close (spool) + + MEF_HDRP(mef) = hdr + + call sfree(sp) +end diff --git a/pkg/xtools/mef/mefsetpl.x b/pkg/xtools/mef/mefsetpl.x new file mode 100644 index 00000000..0df45a4a --- /dev/null +++ b/pkg/xtools/mef/mefsetpl.x @@ -0,0 +1,203 @@ +include <pkg/mef.h> + +define MEF_PLVERSION MEF_HFLAG +define MEF_PLSIZE MEF_CGROUP + +define DEF_SZBUF 32768 +define INC_SZBUF 16384 +define INC_HDRMEM 8100 +define IDB_RECLEN 80 + +define KW_TITLE "$TITLE = " +define LEN_KWTITLE 9 +define KW_CTIME "$CTIME = " +define LEN_KWCTIME 9 +define KW_MTIME "$MTIME = " +define LEN_KWMTIME 9 +define KW_LIMTIME "$LIMTIME = " +define LEN_KWLIMTIME 11 +define KW_MINPIXVAL "$MINPIXVAL = " +define LEN_KWMINPIXVAL 13 +define KW_MAXPIXVAL "$MAXPIXVAL = " +define LEN_KWMAXPIXVAL 13 + +define SZ_IMTITLE 383 # image title string + +procedure mef_setpl (version, plsize, imhdr, title, ctime, mtime, limtime, + minval, maxval, mef) + +int version #I PL version number +char imhdr[ARB] #I Mask title +char title[ARB] +int plsize #I Mask size of TY_SHORT +int ctime +int mtime +int limtime +real minval +real maxval +pointer mef #I Mef descriptor + +int tlen, i, ch, hdrlen, nchars +pointer sp, tbuf, ip, op, rp, bp, hd +int strncmp(), ctol(), ctor(), strlen() +errchk realloc + +begin + MEF_PLVERSION(mef) = version + MEF_PLSIZE(mef) = plsize + tlen= strlen(imhdr) + + call smark (sp) + call salloc (tbuf, SZ_IMTITLE, TY_CHAR) + call salloc (bp, tlen, TY_CHAR) + + call strcpy (imhdr, Memc[bp], tlen) + + + # Get the image title string. + for (ip = bp; Memc[ip] != EOS;) { + if (Memc[ip] == '$') { + if (strncmp (Memc[ip], KW_TITLE, LEN_KWTITLE) == 0) { + # Advance to first character of quoted string. + ip = ip + LEN_KWTITLE + while (Memc[ip] != EOS && Memc[ip] != '"') + ip = ip + 1 + if (Memc[ip] == '"') + ip = ip + 1 + + # Extract the string. + op = tbuf + while (Memc[ip] != EOS && Memc[ip] != '"') { + if (Memc[ip] == '\\' && Memc[ip+1] == '"') + ip = ip + 1 + Memc[op] = Memc[ip] + op = min (tbuf + SZ_IMTITLE, op + 1) + ip = ip + 1 + } + + # Store in image descriptor. + Memc[op] = EOS + call strcpy (Memc[tbuf], title, SZ_IMTITLE) + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_CTIME, LEN_KWCTIME) == 0) { + # Decode the create time. + ip = ip + LEN_KWCTIME + rp = 1 + if (ctol (Memc[ip], rp, ctime) <= 0) + ctime = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_MTIME, LEN_KWMTIME) == 0) { + # Decode the modify time. + ip = ip + LEN_KWMTIME + rp = 1 + if (ctol (Memc[ip], rp, mtime) <= 0) + mtime = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_LIMTIME, LEN_KWLIMTIME) == 0) { + # Decode the limits time. + ip = ip + LEN_KWLIMTIME + rp = 1 + if (ctol (Memc[ip], rp, limtime) <= 0) + limtime = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp(Memc[ip],KW_MINPIXVAL,LEN_KWMINPIXVAL)==0) { + # Decode the minimum pixel value. + ip = ip + LEN_KWMINPIXVAL + rp = 1 + if (ctor (Memc[ip], rp, minval) <= 0) + minval = 0.0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp(Memc[ip],KW_MAXPIXVAL,LEN_KWMAXPIXVAL)==0) { + # Decode the maximum pixel value. + ip = ip + LEN_KWMAXPIXVAL + rp = 1 + if (ctor (Memc[ip], rp, maxval) <= 0) + maxval = 0.0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + } + } else + break + } + + hdrlen = tlen*2 + call malloc (hd, hdrlen, TY_CHAR) + op = hd + + while (Memc[ip] != EOS) { + rp = op + + nchars = rp - hd + if (nchars + IDB_RECLEN + 2 > hdrlen) { + hdrlen = hdrlen + INC_HDRMEM + call realloc (hd, hdrlen, TY_CHAR) + op = hd + nchars + } + # Copy the saved card, leave IP positioned to past newline. + do i = 1, IDB_RECLEN { + ch = Memc[ip] + if (ch != EOS) + ip = ip + 1 + if (ch == '\n') + break + Memc[op] = ch + op = op + 1 + } + + # Blank fill the card. + while (op - rp < IDB_RECLEN) { + Memc[op] = ' ' + op = op + 1 + } + + # Add newline termination. + Memc[op] = '\n'; op = op + 1 + } + + Memc[op] = EOS + + MEF_HDRP(mef) = hd + MEF_HSIZE(mef) = strlen(Memc[hd]) + + call sfree (sp) +end + diff --git a/pkg/xtools/mef/mefwrhdr.x b/pkg/xtools/mef/mefwrhdr.x new file mode 100644 index 00000000..90ec337e --- /dev/null +++ b/pkg/xtools/mef/mefwrhdr.x @@ -0,0 +1,212 @@ +include <error.h> +include <pkg/mef.h> + +# MEF_WRHDR -- Append the header from an input PHU or extension to output file. + +procedure mef_wrhdr (mefi, mefo, in_phdu) + +pointer mefi #I input mef descriptor +pointer mefo #I output mef descriptor +bool in_phdu #I true if input header is Primary Header Unit. + +pointer hb, sp, ln +int output_lines, out, offset +int i, index, naxis, mef_kctype(), strncmp(), note() +bool endk, new_outf +errchk open, fcopyo + +define nextb_ 99 + +begin + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + # At this point the input first header has been read + + hb = MEF_HDRP(mefi) + if (Memc[hb] == NULL) + call error(13,"mef_wrhdr: input header buffer is empty") + + out = MEF_FD(mefo) + + new_outf = false + if (MEF_ACMODE(mefo) == NEW_IMAGE) + new_outf = true + + output_lines = 0 + endk = false + + # If we want to copy the header with no modification + if (MEF_KEEPXT(mefo) == YES) { + for (i=1; i<37; i=i+1) { + switch (mef_kctype(Memc[hb], index)) { + case END: + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + break + default: + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + } + } + goto nextb_ + } + + # Check for 1st card + if (strncmp (Memc[hb], "SIMPLE ", 8) == 0) { + # Append extension to existing file + if (!new_outf) { + call mef_encodec ("XTENSION", "IMAGE", 5, Memc[ln], + "Image extension") + call mef_pakwr (out, Memc[ln]) + } else + call mef_pakwr (out, Memc[hb]) + } else if (strncmp (Memc[hb], "XTENSION", 8) == 0 ) { + if (new_outf) { + # Create a PHU + # Must create a dummy header if input extension is not image + if (strncmp (MEF_EXTTYPE(mefi), "IMAGE", 5) != 0) { + Memc[ln] = EOS + call mef_dummyhdr (out, Memc[ln]) + new_outf = false + call mef_pakwr (out, Memc[hb]) + } else { + call mef_encodeb ("SIMPLE", YES, Memc[ln], + "Standard FITS format") + call mef_pakwr (out, Memc[ln]) + } + } else + call mef_pakwr (out, Memc[hb]) + } else { + # Is the wrong kind of header +# call eprintf ("File %s is not FITS\n") +# call erract (EA_FATAL) + call sprintf (Memc[ln],LEN_CARD, "File %s is not FITS") + call pargstr(MEF_FNAME(mefi)) + call error(13, Memc[ln]) + } + hb = hb + LEN_CARDNL + + for (i=2; i<37; i=i+1) { + switch (mef_kctype(Memc[hb], index)) { + case BITPIX: + # Get to calculate totpix value + call mef_gvali (Memc[hb], MEF_BITPIX(mefi)) + case NAXIS: + naxis = index + MEF_NDIM(mefi) = index + if (in_phdu && !new_outf && naxis == 0) { + call mef_pakwr (out, Memc[hb]) + call mef_wrpgcount (out) + output_lines = output_lines + 2 + hb = hb + LEN_CARDNL + next + } + case NAXISN: + call mef_gvali (Memc[hb], MEF_NAXIS(mefi,index)) + call mef_pakwr (out, Memc[hb]) + if (index == naxis) { + if (in_phdu && !new_outf ) { + # We are writing from a phu to ehu. + # 2 new cards PCOUNT and GCOUNT + + call mef_wrpgcount (out) + output_lines = output_lines + 2 + } + if (!in_phdu && new_outf) { + # We are writing from a ehu to a phu + call mef_encodeb ("EXTEND", YES, Memc[ln], + "There may be extensions") + call mef_pakwr (out, Memc[ln]) + output_lines = output_lines + 1 + } + } + hb = hb + LEN_CARDNL + next + case EXTEND, FILENAME: + if (!new_outf) { + # Do not put these cards when going to an ehu + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case INHERIT: + # Eliminate INHERIT keyword from an input IMAGE extension + # when creating a new output file. If file already exists + # then pass the card along. + + if (new_outf) { + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case PCOUNT,GCOUNT,EXTNAME,EXTVER: + # Do not put these cards into PHU + if (new_outf) { + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case END: + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + output_lines + break + default: + ; + } + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + + } # end for loop + +nextb_ + # See if we need to keep reading header + # + if (!endk) + repeat { + for (i=1; i<37; i=i+1) { + if (strncmp (Memc[hb], "END ", 8) == 0) { + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + output_lines + break + } + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + } + if (endk) break + + } #end repeat + + offset = note(out)-1 # to base zero + call mef_padfile (out, offset) + call flush(out) + + call sfree(sp) +end + +procedure mef_padfile (fd, offset) + +int fd # file descriptor +int offset # file position in chars + +int pad, nlines,i +char card[LEN_CARDNL] + +begin + i = mod(offset, 1440) + if (i == 0) return + + pad = 1440 - i + nlines = pad/40 + + do i =1, 80 + card[i] = ' ' + call achtcb (card, card, 80) + + for(i=1; i<=nlines; i=i+1) + call write(fd, card, 40) + +end diff --git a/pkg/xtools/mef/mefwrhdr.x_save b/pkg/xtools/mef/mefwrhdr.x_save new file mode 100644 index 00000000..ef1c332b --- /dev/null +++ b/pkg/xtools/mef/mefwrhdr.x_save @@ -0,0 +1,185 @@ +include <error.h> +include <mef.h> + +# MEF_WRHDR -- Append the header from an input PHU or extension to output file. + +procedure mef_wrhdr (mefi, mefo, in_phdu) + +pointer mefi #I input mef descriptor +pointer mefo #I output mef descriptor +bool in_phdu #I true if input header is Primary Header Unit. + +pointer hb, sp, ln +int output_lines, out +int i, index, naxis, mef_kctype(), strncmp() +bool endk, new_outf +errchk open, fcopyo + +define nextb_ 99 + +begin + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + # At this point the input first header has been read + + hb = MEF_HDRP(mefi) + if (Memc[hb] == NULL) + call error(13,"mef_wrhdr: input header buffer is empty") + + out = MEF_FD(mefo) + + new_outf = false + if (MEF_ACMODE(mefo) == NEW_IMAGE) + new_outf = true + + output_lines = 0 + endk = false + + # If we want to copy the header with no modification + if (MEF_KEEPXT(mefo) == YES) { + for (i=1; i<37; i=i+1) { + switch (mef_kctype(Memc[hb], index)) { + case END: + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + break + default: + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + } + } + goto nextb_ + } + + # Check for 1st card + if (strncmp (Memc[hb], "SIMPLE ", 8) == 0) { + # Append extension to existing file + if (!new_outf) { + call mef_encodec ("XTENSION", "IMAGE", 5, Memc[ln], + "Image extension") + call mef_pakwr (out, Memc[ln]) + } else + call mef_pakwr (out, Memc[hb]) + } else if (strncmp (Memc[hb], "XTENSION", 8) == 0 ) { + if (new_outf) { + # Create a PHU + # Must create a dummy header if input extension is not image + if (strncmp (MEF_EXTTYPE(mefi), "IMAGE", 5) != 0) { + Memc[ln] = EOS + call mef_dummyhdr (out, Memc[ln]) + new_outf = false + call mef_pakwr (out, Memc[hb]) + } else { + call mef_encodeb ("SIMPLE", YES, Memc[ln], + "Standard FITS format") + call mef_pakwr (out, Memc[ln]) + } + } else + call mef_pakwr (out, Memc[hb]) + } else { + # Is the wrong kind of header +# call eprintf ("File %s is not FITS\n") +# call erract (EA_FATAL) + call sprintf (Memc[ln],LEN_CARD, "File %s is not FITS") + call pargstr(MEF_FNAME(mefi)) + call error(13, Memc[ln]) + } + hb = hb + LEN_CARDNL + + for (i=2; i<37; i=i+1) { + switch (mef_kctype(Memc[hb], index)) { + case BITPIX: + # Get to calculate totpix value + call mef_gvali (Memc[hb], MEF_BITPIX(mefi)) + case NAXIS: + naxis = index + MEF_NDIM(mefi) = index + if (in_phdu && !new_outf && naxis == 0) { + call mef_pakwr (out, Memc[hb]) + call mef_wrpgcount (out) + output_lines = output_lines + 2 + hb = hb + LEN_CARDNL + next + } + case NAXISN: + call mef_gvali (Memc[hb], MEF_NAXIS(mefi,index)) + call mef_pakwr (out, Memc[hb]) + if (index == naxis) { + if (in_phdu && !new_outf ) { + # We are writing from a phu to ehu. + # 2 new cards PCOUNT and GCOUNT + + call mef_wrpgcount (out) + output_lines = output_lines + 2 + } + if (!in_phdu && new_outf) { + # We are writing from a ehu to a phu + call mef_encodeb ("EXTEND", YES, Memc[ln], + "There may be extensions") + call mef_pakwr (out, Memc[ln]) + output_lines = output_lines + 1 + } + } + hb = hb + LEN_CARDNL + next + case EXTEND, FILENAME: + if (!new_outf) { + # Do not put these cards when going to an ehu + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case INHERIT: + # Eliminate INHERIT keyword from an input IMAGE extension + # when creating a new output file. If file already exists + # then pass the card along. + + if (new_outf) { + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case PCOUNT,GCOUNT,EXTNAME,EXTVER: + # Do not put these cards into PHU + if (new_outf) { + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case END: + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + output_lines + break + default: + ; + } + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + + } # end for loop + +nextb_ + # See if we need to keep reading header + # + if (!endk) + repeat { + for (i=1; i<37; i=i+1) { + if (strncmp (Memc[hb], "END ", 8) == 0) { + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + output_lines + break + } + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + } + if (endk) break + + } #end repeat + call mef_wrblank (out, output_lines) + + call sfree(sp) +end diff --git a/pkg/xtools/mef/mefwrpl.x b/pkg/xtools/mef/mefwrpl.x new file mode 100644 index 00000000..1eef1cc2 --- /dev/null +++ b/pkg/xtools/mef/mefwrpl.x @@ -0,0 +1,213 @@ +include <error.h> +include <pkg/mef.h> + +define MEF_PLSIZE MEF_CGROUP +# MEF_WRPL -- + +procedure mef_wrpl (mef, title, ctime,mtime, limtime, minval, + maxval,plbuf, naxis, axlen) + +char title[ARB] +int ctime, mtime, limtime +real minval, maxval +pointer mef #I input mef descriptor +short plbuf #I Pixel list buffer +int naxis, axlen[ARB] + +pointer sp, ln, mii, hb +char blank[1] +int output_lines, npad, i +int pcount, fd, nlines +bool endk, new_outf +errchk open, fcopyo + +begin + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + # Output file descriptor + fd = MEF_FD(mef) + + new_outf = false + if (MEF_ACMODE(mef) == NEW_IMAGE) + new_outf = true + + output_lines = 0 + endk = false + + # Create a PHU + if (new_outf) { + # Must create a dummy header if input extension is not image + Memc[ln] = EOS + call mef_dummyhdr (fd, Memc[ln]) + new_outf = false + } + + call mef_wcardc ("XTENSION", "BINTABLE", "Extension type", fd) + call mef_wcardi ("BITPIX", 8, "Default value", fd) + call mef_wcardi ("NAXIS", 2, "Lines and cols", fd) + call mef_wcardi ("NAXIS1", 8, "Nbytes per line", fd) + call mef_wcardi ("NAXIS2", 1, "Nlines", fd) + + # Calculate the number of 2880 bytes block the heap will + # occupy. + + pcount = ((MEF_PLSIZE(mef)+1439)/1440)*2880 + call mef_wcardi ("PCOUNT", pcount, "Heap size in bytes", fd) + call mef_wcardi ("GCOUNT", 1, "1 Group", fd) + call mef_wcardi ("TFIELDS", 1, "1 Column field", fd) + call sprintf (Memc[ln], LEN_CARD, "PI(%d)") + call pargi(MEF_PLSIZE(mef)) + call mef_wcardc ("TFORM1", Memc[ln], "Variable word array", fd) + call mef_wcardb ("INHERIT", NO, "No Inherit", fd) + call mef_wcardc ("ORIGIN", FITS_ORIGIN, "FITS file originator", fd) + call mef_wcardc ("EXTNAME", MEF_EXTNAME(mef), "", fd) + call mef_wcardi ("EXTVER", MEF_EXTVER(mef), "", fd) + call mef_wcardi ("CTIME", ctime, "", fd) + call mef_wcardi ("MTIME", mtime, "", fd) + call mef_wcardi ("LIMTIME", limtime, "", fd) + call mef_wcardr ("DATAMIN", minval, "", fd) + call mef_wcardr ("DATAMAX", maxval, "", fd) + call mef_wcardc ("OBJECT", title, "", fd) + + call mef_wcardb ("CMPIMAGE", YES, "Is a compressed image", fd) + call mef_wcardc ("CMPTYPE", "PLIO_1", "IRAF image masks", fd) + call mef_wcardi ("CBITPIX", 32, "BITPIX for uncompressed image", fd) + call mef_wcardi ("CNAXIS", naxis, "NAXIS for uncompressed image", fd) + do i = 1, naxis { + call sprintf (Memc[ln], LEN_CARD, "NAXIS%d") + call pargi(i) + call mef_wcardi ("CNAXIS", axlen[i], "axis length", fd) + } + + hb = MEF_HDRP(mef) + output_lines = 23 + nlines = MEF_HSIZE(mef) / LEN_CARDNL + + for (i=1; i<= nlines; i=i+1) { + call mef_pakwr (fd, Memc[hb]) + hb = hb + LEN_CARDNL + } + + blank[1] = ' ' + call amovkc (blank, Memc[ln], 80) + call strcpy ("END", Memc[ln], 3) + Memc[ln+3] = ' ' # Clear EOS mark + call mef_pakwr (fd, Memc[ln]) + + output_lines = output_lines + nlines + 1 + naxis + call mef_wrblank (fd, output_lines) + + call salloc (mii, 1400, TY_INT) + + # Now write 2 integers as table data (nelem,offset) + Memi[mii] = MEF_PLSIZE(mef) # Number of words in pl buff (2bytes) + Memi[mii+1] = 0 # Offset from start of heap + + npad = 1438 + call amovki (0, Memi[mii+2], npad) + call write (fd, Memi[mii], 1440) + + # Write mask in heap area + call write (fd, plbuf, MEF_PLSIZE(mef)*SZ_SHORT) + + # Pad to 1440 characters block in case we want to append another + # extension + + npad = 1440 - mod (MEF_PLSIZE(mef), 1440) + + call amovki (0, Memi[mii], npad) + call write (fd, Memi[mii], npad) + + + call sfree(sp) +end + +procedure mef_wcardi (kname, kvalue, kcomm, fd) + +char kname[ARB] #I Keyword name +int kvalue #I Keyword value +char kcomm[ARB] #I Card comment +int fd #I file descriptor + +pointer sp, ln + +begin + + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + call mef_encodei (kname, kvalue, Memc[ln], kcomm) + call mef_pakwr (fd, Memc[ln]) + + call sfree (sp) + +end + + +procedure mef_wcardc (kname, kvalue, kcomm, fd) + +char kname[ARB] #I Keyword name +char kvalue[ARB] #I Keyword value +char kcomm[ARB] #I Card comment +int fd #I file descriptor + +pointer sp, ln +int slen, strlen() + +begin + + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + slen = strlen(kvalue) + call mef_encodec (kname, kvalue, slen, Memc[ln], kcomm) + call mef_pakwr (fd, Memc[ln]) + + call sfree(sp) + +end + + +procedure mef_wcardb (kname, kvalue, kcomm, fd) + +char kname[ARB] #I Keyword name +int kvalue #I Keyword value +char kcomm[ARB] #I Card comment +int fd #I file descriptor + +pointer sp, ln + +begin + + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + call mef_encodeb (kname, kvalue, Memc[ln], kcomm) + call mef_pakwr (fd, Memc[ln]) + + call sfree(sp) + +end + +procedure mef_wcardr (kname, kvalue, kcomm, fd) + +char kname[ARB] #I Keyword name +real kvalue #I Keyword value +char kcomm[ARB] #I Card comment +int fd #I file descriptor + +pointer sp, ln + +begin + + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + call mef_encoder (kname, kvalue, Memc[ln], kcomm, 6) + call mef_pakwr (fd, Memc[ln]) + + call sfree(sp) + +end + diff --git a/pkg/xtools/mef/mkpkg b/pkg/xtools/mef/mkpkg new file mode 100644 index 00000000..5a3f358c --- /dev/null +++ b/pkg/xtools/mef/mkpkg @@ -0,0 +1,26 @@ +# MEFLIB + +update: + $checkout libxtools.a lib$ + $update libxtools.a + $checkin libxtools.a lib$ + ; + +libxtools.a: + mefappfile.x <pkg/mef.h> + mefclose.x <pkg/mef.h> + mefcpextn.x <mach.h> <pkg/mef.h> + mefdummyh.x <pkg/mef.h> + mefencode.x <ctype.h> <mach.h> <pkg/mef.h> <time.h> + mefget.x <ctype.h> <pkg/mef.h> + mefgnbc.x <pkg/mef.h> + mefgval.x <ctype.h> <pkg/mef.h> + mefkfind.x <pkg/mef.h> + mefksection.x <ctotok.h> <lexnum.h> <pkg/mef.h> + mefldhdr.x <ctype.h> <error.h> <mach.h> <pkg/mef.h> <mii.h> + mefopen.x <pkg/mef.h> + mefrdhdr.x <ctype.h> <error.h> <fset.h> <mach.h> <pkg/mef.h> + mefsetpl.x <pkg/mef.h> + mefwrhdr.x <error.h> <pkg/mef.h> + mefwrpl.x <error.h> <pkg/mef.h> + ; diff --git a/pkg/xtools/mkpkg b/pkg/xtools/mkpkg new file mode 100644 index 00000000..57eedf4e --- /dev/null +++ b/pkg/xtools/mkpkg @@ -0,0 +1,80 @@ +# XTOOLS Programming tools library. + +update: + $checkout libxtools.a lib$ + $update libxtools.a + $checkin libxtools.a lib$ + $purge lib$ + ; + +txtcompile: + $omake t_txtcompile.x + $link t_txtcompile.o -lxtools -o xx_txtcompile.e + $move xx_txtcompile.o bin$x_txtcompile.e + ; + +generic: + $set GEN = "$$generic -k" + $ifolder (xtsample.x, xtsample.gx) + $(GEN) xtsample.gx -o xtsample.x $endif + $ifolder (xtstat.x, xtstat.gx) + $(GEN) xtstat.gx -o xtstat.x $endif + ; + +libxtools.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + @ranges # Range tools "1:10,5:20,30" + @gtools # Graphics tools + @icfit # Interactive curfit package + @inlfit # Interactive non-linear least-squares package + @fixpix # Mask and pixel fixing routines + @skywcs # Sky coordinates transformation routines + @catquery # Catalog and survey access routines + @mef # MEF handling routines + + center1d.x <math/iminterp.h> <pkg/center1d.h> + clgcurfit.x <math/curfit.h> + clginterp.x <math/iminterp.h> + clgsec.x <ctype.h> <imhdr.h> <mach.h> + cogetr.x cogetr.h <imhdr.h> + dttext.x <ctotok.h> <ctype.h> <error.h> <finfo.h> <fset.h>\ + <pkg/dttext.h> <time.h> + extrema.x + getdatatype.x + gstrdetab.x + gstrentab.x + gstrsettab.x + imtools.x <ctype.h> <imhdr.h> + intrp.f + isdir.x <ctype.h> <finfo.h> + peaks.x + ranges.x <ctype.h> <mach.h> + rmmed.x <pkg/rmsorted.h> <mach.h> + rmsorted.x <pkg/rmsorted.h> + rmturlach.x <mach.h> + rngranges.x <ctype.h> <mach.h> + obsdb.x <error.h> <imset.h> + strdetab.x + strentab.x + syshost.x <clset.h> <ctotok.h> + xt21imsum.x <imhdr.h> + xtanswer.x <pkg/xtanswer.h> + xtargs.x <ctotok.h> + xtbitarray.x <mach.h> + xtextns.x <ctype.h> <error.h> <mach.h> <pkg/mef.h> + xtgids.x <ctotok.h> + xtimleneq.x <imhdr.h> + xtimnames.x + xtimtgetim.x + xtlogfiles.x + xtmaskname.x + xtmksection.x <imhdr.h> + xtphistory.x <imhdr.h> + xtsample.x <imhdr.h> + xtsort.x + xtstat.x + xtstripwhite.x <ctype.h> + xtsums.x + xttxtfio.x + ; diff --git a/pkg/xtools/numrecipes.x b/pkg/xtools/numrecipes.x new file mode 100644 index 00000000..ae437b6d --- /dev/null +++ b/pkg/xtools/numrecipes.x @@ -0,0 +1,689 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math.h> +include <mach.h> + +# GAMMLN -- Return natural log of gamma function. +# POIDEV -- Returns Poisson deviates for a given mean. +# GASDEV -- Return a normally distributed deviate of zero mean and unit var. +# MR_SOLVE -- Levenberg-Marquardt nonlinear chi square minimization. +# MR_EVAL -- Evaluate curvature matrix. +# MR_INVERT -- Solve a set of linear equations using Householder transforms. +# TWOFFT -- Returns the complex FFTs of two input real arrays. +# REALFT -- Calculates the FFT of a set of 2N real valued data points. +# FOUR1 -- Computes the forward or inverse FFT of the input array. + + +# GAMMLN -- Return natural log of gamma function. +# Argument must greater than 0. Full accuracy is obtained for values +# greater than 1. For 0<xx<1, the reflection formula can be used first. +# +# Based on Numerical Recipes by Press, Flannery, Teukolsky, and Vetterling. +# Used by permission of the authors. +# Copyright(c) 1986 Numerical Recipes Software. + +real procedure gammln (xx) + +real xx # Value to be evaluated + +int j +double cof[6], stp, x, tmp, ser +data cof, stp / 76.18009173D0, -86.50532033D0, 24.01409822D0, + -1.231739516D0,.120858003D-2,-.536382D-5,2.50662827465D0/ + +begin + x = xx - 1.0D0 + tmp = x + 5.5D0 + tmp = (x + 0.5D0) * log (tmp) - tmp + ser = 1.0D0 + do j = 1, 6 { + x = x + 1.0D0 + ser = ser + cof[j] / x + } + return (tmp + log (stp * ser)) +end + + +# POIDEV -- Returns Poisson deviates for a given mean. +# The real value returned is an integer. +# +# Based on Numerical Recipes by Press, Flannery, Teukolsky, and Vetterling. +# Used by permission of the authors. +# Copyright(c) 1986 Numerical Recipes Software. +# +# Modified to return zero for input values less than or equal to zero. + +real procedure poidev (xm, seed) + +real xm # Poisson mean +long seed # Random number seed + +real oldm, g, em, t, y, ymin, ymax, sq, alxm, gammln(), urand(), gasdev() +data oldm /-1./ + +begin + if (xm <= 0) + em = 0 + else if (xm < 12) { + if (xm != oldm) { + oldm = xm + g = exp (-xm) + } + em = 0 + for (t = urand (seed); t > g; t = t * urand (seed)) + em = em + 1 + } else if (xm < 100) { + if (xm != oldm) { + oldm = xm + sq = sqrt (2. * xm) + ymin = -xm / sq + ymax = (1000 - xm) / sq + alxm = log (xm) + g = xm * alxm - gammln (xm+1.) + } + repeat { + repeat { + y = tan (PI * urand(seed)) + } until (y >= ymin) + em = int (sq * min (y, ymax) + xm) + t = 0.9 * (1 + y**2) * exp (em * alxm - gammln (em+1) - g) + } until (urand(seed) <= t) + } else + em = xm + sqrt (xm) * gasdev (seed) + return (em) +end + + +# GASDEV -- Return a normally distributed deviate with zero mean and unit +# variance. The method computes two deviates simultaneously. +# +# Based on Numerical Recipes by Press, Flannery, Teukolsky, and Vetterling. +# Used by permission of the authors. +# Copyright(c) 1986 Numerical Recipes Software. + +real procedure gasdev (seed) + +long seed # Seed for random numbers + +real v1, v2, r, fac, urand() +int iset +data iset/0/ + +begin + if (iset == 0) { + repeat { + v1 = 2 * urand (seed) - 1. + v2 = 2 * urand (seed) - 1. + r = v1 ** 2 + v2 ** 2 + } until ((r > 0) && (r < 1)) + fac = sqrt (-2. * log (r) / r) + + iset = 1 + return (v1 * fac) + } else { + iset = 0 + return (v2 * fac) + } +end + + +# MR_SOLVE -- Levenberg-Marquardt nonlinear chi square minimization. +# +# Use the Levenberg-Marquardt method to minimize the chi squared of a set +# of paraemters. The parameters being fit are indexed by the flag array. +# To initialize the Marquardt parameter, MR, is less than zero. After that +# the parameter is adjusted as needed. To finish set the parameter to zero +# to free memory. This procedure requires a subroutine, DERIVS, which +# takes the derivatives of the function being fit with respect to the +# parameters. There is no limitation on the number of parameters or +# data points. For a description of the method see NUMERICAL RECIPES +# by Press, Flannery, Teukolsky, and Vetterling, p523. +# +# These routines have their origin in Numerical Recipes, MRQMIN, MRQCOF, +# but have been completely redesigned. + +procedure mr_solve (x, y, npts, params, flags, np, nfit, mr, chisq) + +real x[npts] # X data array +real y[npts] # Y data array +int npts # Number of data points +real params[np] # Parameter array +int flags[np] # Flag array indexing parameters to fit +int np # Number of parameters +int nfit # Number of parameters to fit +real mr # MR parameter +real chisq # Chi square of fit + +int i +real chisq1 +pointer new, a1, a2, delta1, delta2 + +errchk mr_invert + +begin + # Allocate memory and initialize. + if (mr < 0.) { + call mfree (new, TY_REAL) + call mfree (a1, TY_REAL) + call mfree (a2, TY_REAL) + call mfree (delta1, TY_REAL) + call mfree (delta2, TY_REAL) + + call malloc (new, np, TY_REAL) + call malloc (a1, nfit*nfit, TY_REAL) + call malloc (a2, nfit*nfit, TY_REAL) + call malloc (delta1, nfit, TY_REAL) + call malloc (delta2, nfit, TY_REAL) + + call amovr (params, Memr[new], np) + call mr_eval (x, y, npts, Memr[new], flags, np, Memr[a2], + Memr[delta2], nfit, chisq) + mr = 0.001 + } + + # Restore last good fit and apply the Marquardt parameter. + call amovr (Memr[a2], Memr[a1], nfit * nfit) + call amovr (Memr[delta2], Memr[delta1], nfit) + do i = 1, nfit + Memr[a1+(i-1)*(nfit+1)] = Memr[a2+(i-1)*(nfit+1)] * (1. + mr) + + # Matrix solution. + call mr_invert (Memr[a1], Memr[delta1], nfit) + + # Compute the new values and curvature matrix. + do i = 1, nfit + Memr[new+flags[i]-1] = params[flags[i]] + Memr[delta1+i-1] + call mr_eval (x, y, npts, Memr[new], flags, np, Memr[a1], + Memr[delta1], nfit, chisq1) + + # Check if chisq has improved. + if (chisq1 < chisq) { + mr = 0.1 * mr + chisq = chisq1 + call amovr (Memr[a1], Memr[a2], nfit * nfit) + call amovr (Memr[delta1], Memr[delta2], nfit) + call amovr (Memr[new], params, np) + } else + mr = 10. * mr + + if (mr == 0.) { + call mfree (new, TY_REAL) + call mfree (a1, TY_REAL) + call mfree (a2, TY_REAL) + call mfree (delta1, TY_REAL) + call mfree (delta2, TY_REAL) + } +end + + +# MR_EVAL -- Evaluate curvature matrix. This calls procedure DERIVS. + +procedure mr_eval (x, y, npts, params, flags, np, a, delta, nfit, chisq) + +real x[npts] # X data array +real y[npts] # Y data array +int npts # Number of data points +real params[np] # Parameter array +int flags[np] # Flag array indexing parameters to fit +int np # Number of parameters +real a[nfit,nfit] # Curvature matrix +real delta[nfit] # Delta array +int nfit # Number of parameters to fit +real chisq # Chi square of fit + +int i, j, k +real ymod, dy, dydpj, dydpk +pointer sp, dydp + +begin + call smark (sp) + call salloc (dydp, np, TY_REAL) + + do j = 1, nfit { + do k = 1, j + a[j,k] = 0. + delta[j] = 0. + } + + chisq = 0. + do i = 1, npts { + call derivs (x[i], params, ymod, Memr[dydp], np) + dy = y[i] - ymod + do j = 1, nfit { + dydpj = Memr[dydp+flags[j]-1] + delta[j] = delta[j] + dy * dydpj + do k = 1, j { + dydpk = Memr[dydp+flags[k]-1] + a[j,k] = a[j,k] + dydpj * dydpk + } + } + chisq = chisq + dy * dy + } + + do j = 2, nfit + do k = 1, j-1 + a[k,j] = a[j,k] + + call sfree (sp) +end + + +# MR_INVERT -- Solve a set of linear equations using Householder transforms. +# This calls a routine published in in "Solving Least Squares Problems", +# by Charles L. Lawson and Richard J. Hanson, Prentice Hall, 1974. + +procedure mr_invert (a, b, n) + +real a[n,n] # Input matrix and returned inverse +real b[n] # Input RHS vector and returned solution +int n # Dimension of input matrices + +int krank +real rnorm +pointer sp, h, g, ip + +begin + call smark (sp) + call salloc (h, n, TY_REAL) + call salloc (g, n, TY_REAL) + call salloc (ip, n, TY_INT) + + call hfti (a, n, n, n, b, n, 1, 0.001, krank, rnorm, + Memr[h], Memr[g], Memi[ip]) + + call sfree (sp) +end + + +# TWOFFT - Given two real input arrays DATA1 and DATA2, each of length +# N, this routine calls cc_four1() and returns two complex output arrays, +# FFT1 and FFT2, each of complex length N (i.e. real length 2*N), which +# contain the discrete Fourier transforms of the respective DATAs. As +# always, N must be an integer power of 2. +# +# Based on Numerical Recipes by Press, Flannery, Teukolsky, and Vetterling. +# Used by permission of the authors. +# Copyright(c) 1986 Numerical Recipes Software. + +procedure twofft (data1, data2, fft1, fft2, N) + +real data1[ARB], data2[ARB] # Input data arrays +real fft1[ARB], fft2[ARB] # Output FFT arrays +int N # No. of points + +int nn3, nn2, jj, j +real rep, rem, aip, aim + +begin + nn2 = 2 + N + N + nn3 = nn2 + 1 + + jj = 2 + for (j=1; j <= N; j = j + 1) { + fft1[jj-1] = data1[j] # Pack 'em into one complex array + fft1[jj] = data2[j] + jj = jj + 2 + } + + call four1 (fft1, N, 1) # Transform the complex array + fft2[1] = fft1[2] + fft2[2] = 0.0 + fft1[2] = 0.0 + for (j=3; j <= N + 1; j = j + 2) { + rep = 0.5 * (fft1[j] + fft1[nn2-j]) + rem = 0.5 * (fft1[j] - fft1[nn2-j]) + aip = 0.5 * (fft1[j + 1] + fft1[nn3-j]) + aim = 0.5 * (fft1[j + 1] - fft1[nn3-j]) + fft1[j] = rep + fft1[j+1] = aim + fft1[nn2-j] = rep + fft1[nn3-j] = -aim + fft2[j] = aip + fft2[j+1] = -rem + fft2[nn2-j] = aip + fft2[nn3-j] = rem + } + +end + + +# REALFT - Calculates the Fourier Transform of a set of 2N real valued +# data points. Replaces this data (which is stored in the array DATA) by +# the positive frequency half of it's complex Fourier Transform. The real +# valued first and last components of the complex transform are returned +# as elements DATA(1) and DATA(2) respectively. N must be an integer power +# of 2. This routine also calculates the inverse transform of a complex +# array if it is the transform of real data. (Result in this case must be +# multiplied by 1/N). A forward transform is perform for isign == 1, other- +# wise the inverse transform is computed. +# +# Based on Numerical Recipes by Press, Flannery, Teukolsky, and Vetterling. +# Used by permission of the authors. +# Copyright(c) 1986 Numerical Recipes Software. + +procedure realft (data, N, isign) + +real data[ARB] # Input data array & output FFT +int N # No. of points +int isign # Direction of transfer + +double wr, wi, wpr, wpi, wtemp, theta # Local variables +real c1, c2, h1r, h1i, h2r, h2i +real wrs, wis +int i, i1, i2, i3, i4 +int N2P3 + +begin + # Initialize + theta = PI/double(N) + c1 = 0.5 + + if (isign == 1) { + c2 = -0.5 + call four1 (data,n,1) # Forward transform is here + } else { + c2 = 0.5 + theta = -theta + } + + wtemp = sin (0.5 * theta) + wpr = -2.0d0 * wtemp * wtemp + wpi = dsin (theta) + wr = 1.0D0 + wpr + wi = wpi + n2p3 = 2*n + 3 + + for (i=2; i<=n/2; i = i + 1) { + i1 = 2 * i - 1 + i2 = i1 + 1 + i3 = n2p3 - i2 + i4 = i3 + 1 + wrs = sngl (wr) + wis = sngl (wi) + # The 2 transforms are separated out of Z + h1r = c1 * (data[i1] + data[i3]) + h1i = c1 * (data[i2] - data[i4]) + h2r = -c2 * (data[i2] + data[i4]) + h2i = c2 * (data[i1] - data[i3]) + # Here they are recombined to form the true + # transform of the original real data. + data[i1] = h1r + wr*h2r - wi*h2i + data[i2] = h1i + wr*h2i + wi*h2r + data[i3] = h1r - wr*h2r + wi*h2i + data[i4] = -h1i + wr*h2i + wi*h2r + + wtemp = wr # The reccurrence + wr = wr * wpr - wi * wpi + wr + wi = wi * wpr + wtemp * wpi + wi + } + + if (isign == 1) { + h1r = data[1] + data[1] = h1r + data[2] + data[2] = h1r - data[2] + } else { + h1r = data[1] + data[1] = c1 * (h1r + data[2]) + data[2] = c1 * (h1r - data[2]) + call four1 (data,n,-1) + } + +end + + +# FOUR1 - Replaces DATA by it's discrete transform, if ISIGN is input +# as 1; or replaces DATA by NN times it's inverse discrete Fourier transform +# if ISIGN is input as -1. Data is a complex array of length NN or, equiv- +# alently, a real array of length 2*NN. NN *must* be an integer power of +# two. +# +# Based on Numerical Recipes by Press, Flannery, Teukolsky, and Vetterling. +# Used by permission of the authors. +# Copyright(c) 1986 Numerical Recipes Software. + +procedure four1 (data, nn, isign) + +real data[ARB] # Data array (returned as FFT) +int nn # No. of points in data array +int isign # Direction of transform + +double wr, wi, wpr, wpi # Local variables +double wtemp, theta +real tempr, tempi +int i, j, istep +int n, mmax, m + +begin + n = 2 * nn + j = 1 + for (i=1; i<n; i = i + 2) { + if (j > i) { # Swap 'em + tempr = data[j] + tempi = data[j+1] + data[j] = data[i] + data[j+1] = data[i+1] + data[i] = tempr + data[i+1] = tempi + } + m = n / 2 + while (m >= 2 && j > m) { + j = j - m + m = m / 2 + } + j = j + m + } + mmax = 2 + while (n > mmax) { + istep = 2 * mmax + theta = TWOPI / double (isign*mmax) + wtemp = dsin (0.5*theta) + wpr = -2.d0 * wtemp * wtemp + wpi = dsin (theta) + wr = 1.d0 + wi = 0.d0 + for (m=1; m < mmax; m = m + 2) { + for (i=m; i<=n; i = i + istep) { + j = i + mmax + tempr = real (wr) * data[j] - real (wi) * data[j+1] + tempi = real (wr) * data[j + 1] + real (wi) * data[j] + data[j] = data[i] - tempr + data[j+1] = data[i+1] - tempi + data[i] = data[i] + tempr + data[i+1] = data[i+1] + tempi + } + wtemp = wr + wr = wr * wpr - wi * wpi + wr + wi = wi * wpr + wtemp * wpi + wi + } + mmax = istep + } +end + + +################################################################################ +# LU Decomosition +################################################################################ +define TINY (1E-20) # Number of numerical limit + +# Given an N x N matrix A, with physical dimension N, this routine +# replaces it by the LU decomposition of a rowwise permutation of +# itself. A and N are input. A is output, arranged as in equation +# (2.3.14) above; INDX is an output vector which records the row +# permutation effected by the partial pivioting; D is output as +/-1 +# depending on whether the number of row interchanges was even or odd, +# respectively. This routine is used in combination with LUBKSB to +# solve linear equations or invert a matrix. +# +# Based on Numerical Recipes by Press, Flannery, Teukolsky, and Vetterling. +# Used by permission of the authors. +# Copyright(c) 1986 Numerical Recipes Software. + +procedure ludcmp (a, n, np, indx, d) + +real a[np,np] +int n +int np +int indx[n] +real d + +int i, j, k, imax +real aamax, sum, dum +pointer vv + +begin + # Allocate memory. + call malloc (vv, n, TY_REAL) + + # Loop over rows to get the implict scaling information. + 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 mfree (vv, TY_REAL) + call error (1, "Singular matrix") + } + Memr[vv+i-1] = 1. / aamax + } + + # This is the loop over columns of Crout's method. + do j = 1, n { + do i = 1, j-1 { + sum = a[i,j] + 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] + 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 + + # Now, finally, divide by the pivot element. + # If the pivot element is zero the matrix is signular (at + # least to the precission of the algorithm. For some + # applications on singular matrices, it is desirable to + # substitute TINY for zero. + + if (a[j,j] == 0.) + a[j,j] = TINY + if (j != n) { + dum = 1. / a[j,j] + do i = j+1, n + a[i,j] = a[i,j] * dum + } + } + + call mfree (vv, TY_REAL) +end + + +# Solves the set of N linear equations AX = B. Here A is input, not +# as the matrix of A but rather as its LU decomposition, determined by +# the routine LUDCMP. INDX is input as the permuation vector returned +# by LUDCMP. B is input as the right-hand side vector B, and returns +# with the solution vector X. A, N, NP and INDX are not modified by +# this routine and can be left in place for successive calls with +# different right-hand sides B. This routine takes into account the +# possiblity that B will begin with many zero elements, so it is +# efficient for use in matrix inversion. +# +# Based on Numerical Recipes by Press, Flannery, Teukolsky, and Vetterling. +# Used by permission of the authors. +# Copyright(c) 1986 Numerical Recipes Software. + +procedure lubksb (a, n, np, indx, b) + +real a[np,np] +int n +int np +int indx[n] +real b[n] + +int i, j, ii, ll +real sum + +begin + ii = 0 + do i = 1, n { + ll = indx[i] + sum = b[ll] + b[ll] = b[i] + if (ii != 0) { + do j = ii, i-1 + sum = sum - a[i,j] * b[j] + } else if (sum != 0.) + ii = i + b[i] = sum + } + + do i = n, 1, -1 { + sum = b[i] + if (i < n) { + do j = i+1, n + sum = sum - a[i,j] * b[j] + } + b[i] = sum / a[i,i] + } +end + + +# Invert a matrix using LU decomposition using A as both input and output. + +procedure luminv (a, n, np) + +real a[np,np] +int n +int np + +int i, j +real d +pointer y, indx + +begin + # Allocate working memory. + call calloc (y, n*n, TY_REAL) + call malloc (indx, n, TY_INT) + + # Setup identify matrix. + do i = 0, n-1 + Memr[y+(n+1)*i] = 1. + + # Do LU decomposition. + call ludcmp (a, n, np, Memi[indx], d) + + # Find inverse by columns. + do j = 0, n-1 + call lubksb (a, n, np, Memi[indx], Memr[y+n*j]) + + # Return inverse in a. + do i = 1, n + do j = 1, n + a[i,j] = Memr[y+n*(j-1)+(i-1)] + + call mfree (y, TY_REAL) +end +################################################################################ diff --git a/pkg/xtools/obsdb.x b/pkg/xtools/obsdb.x new file mode 100644 index 00000000..1bb2ea7d --- /dev/null +++ b/pkg/xtools/obsdb.x @@ -0,0 +1,568 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <syserr.h> +include <imset.h> + +.help obsdb Nov90 "Observatory Database Interface" +.ih +DESCRIPTION + +These procedures provide a simple interface to a simple observatory database. +It uses environment variables if possible to allow users and sites to +set or reset the observatory information. The observatory database is +specified by the environment parameter "obsdb" which defaults to +"noao$lib/obsdb.dat". The observatory may be specified as "observatory" +to look first for the environment parameter "observatory" and then +for the task parameter "observatory.observatory". The observatory +may also be specified as "obspars" to ignore the database and use the +parameters set in observatory task parameter set. This allows setting +arbitrary values without requiring the user modify or create a database +file. The case of the observatory identification is ignored. + +PROCEDURES + +.nf + obs = obsopen (observatory) + obs = obsvopen (observatory, verbose) + obsimopen (obs, im, observatory, verbose, newobs, obshead) + obsclose (obs) + obslog (obs, task, params, fd) + val = obsget[ird] (obs, param) + obsgstr (obs, param, str, maxchar) + obsinfo (obs, fd) +.fi + +DATABASE + +The database file is that defined by the environment variable "obsdb". +If absent the file is "noao$lib/obsdb.dat". The observatory name +used in the obsopen procedure is the observatory ID as defined +in the database, the special string "observatory" which uses +to the environment variable of the same name or the task parameter +"observatory.observatory", or the special string "obspars" which +uses the observatory task parameters and does not require an entry +in the database. + +The database format is simply a list of keyword/value definitions with +arbitrary whitespace allowed for visual formatting. Also comments +beginning with '#' may be used. Parameters for a particular +observatory begin with the "observatory" parameter and end with the +next observatory definitions (or end-of-file). For example: + +.nf +observatory = "kpno" + name = "Kitt Peak National Observatory" + longitude = 111:36.0 + latitude = 31:58.8 + altitude = 2120. + timezone = 7 + +observatory = "ctio" + <etc.> +.fi + +String parameters must be quoted if they contain whitespace. +.ih +SEE ALSO +Source code +.endhelp + + +# Symbol table definitions. +define LEN_INDEX 10 # Length of symtab index +define LEN_STAB 512 # Length of symtab +define SZ_SBUF 512 # Size of symtab string buffer +define SYMLEN 40 # Length of symbol structure +define SZ_OBSVAL 79 # Size of observatory value string + +# Symbol table structure +define OBSVAL Memc[P2C($1)] # Observatory value string + + +# OBSOPEN -- Open observatory database and store the requested observatory +# information in symbol table. + +pointer procedure obsopen (observatory) + +char observatory[ARB] # Observatory name +pointer obsvopen() +errchk obsvopen + +begin + return (obsvopen (observatory, NO)) +end + + +# OBSVOPEN -- Open observatory database and store the requested observatory +# information in symbol table. + +pointer procedure obsvopen (observatory, verbose) + +char observatory[ARB] # Observatory name +int verbose # Verbose? +pointer obs # Observatory symbol table pointer + +int fd, envfind(), envgets(), open(), fscan(), nscan(), nowhite() +pointer sp, fname, obsname, key, str, temp, sym +pointer stopen(), stenter() +bool found, streq(), strne() +errchk open, stopen, stenter, envfind, envgets, fscan + +string obskey "observatory" +define getobs_ 99 + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (obsname, SZ_FNAME, TY_CHAR) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (temp, SZ_LINE, TY_CHAR) + + # Open observatory database. + if (envfind ("obsdb", Memc[fname], SZ_FNAME) <= 0) { + call strcpy ("noao$lib/obsdb.dat", Memc[fname], SZ_FNAME) + if (verbose == YES) { + call eprintf ("Using default observatory database: %s\n") + call pargstr ("noao$lib/obsdb.dat") + } + } else if (verbose == YES) { + call eprintf ( + "Using database defined by '%s' environment variable: %s\n") + call pargstr ("obsdb") + call pargstr (Memc[fname]) + } + fd = open (Memc[fname], READ_ONLY, TEXT_FILE) + + # Set observatory from the environment or task parameter if needed. + # Convert to lower case but save original name for documentation. + + if (streq (observatory, obskey)) { + if (envgets (obskey, Memc[obsname], SZ_FNAME) <= 0) { + call clgstr ("observatory.observatory", Memc[obsname], SZ_FNAME) + if (verbose == YES) { + call eprintf ( + "Using observatory defined by observatory task: %s\n") + call pargstr (Memc[obsname]) + } + } else if (verbose == YES) { + call eprintf ( + "Using observatory defined by '%s' environment variable: %s\n") + call pargstr (observatory) + call pargstr (Memc[obsname]) + } + } else + call strcpy (observatory, Memc[obsname], SZ_LINE) + +getobs_ + # Strip whitespace and convert to lower case. + call strcpy (Memc[obsname], Memc[temp], SZ_LINE) + if (nowhite (Memc[obsname], Memc[obsname], SZ_LINE) > 0) + call strlwr (Memc[obsname]) + + if (streq (Memc[obsname], "obspars")) { + if (verbose == YES) { + call eprintf ( + "Using observatory parameters from observatory task\n") + } + + # Create symbol table. + obs = stopen (Memc[obsname], LEN_INDEX, LEN_STAB, SZ_SBUF) + sym = stenter (obs, obskey, SYMLEN) + call strcpy (Memc[obsname], OBSVAL(sym), SZ_OBSVAL) +# sym = obspars (obs, "name") +# sym = obspars (obs, "longitude") +# sym = obspars (obs, "latitude") +# sym = obspars (obs, "altitude") +# sym = obspars (obs, "timezone") + } else { + if (verbose == YES) { + call eprintf ( + "Using observatory parameters for database entry: %s\n") + call pargstr (Memc[temp]) + } + + # Find observatory entry. + found = false + while (fscan (fd) != EOF) { + call gargwrd (Memc[key], SZ_FNAME) + call gargwrd (Memc[str], SZ_LINE) + call gargwrd (Memc[str], SZ_LINE) + if (nscan()<3 || Memc[key]=='#' || strne (Memc[key], obskey)) + next + call strlwr (Memc[str]) + if (streq (Memc[str], Memc[obsname])) { + found = true + break + } + } + + # Check if entry was found. + if (!found) { + if (Memc[obsname] != EOS && Memc[obsname] != '?') { + call eprintf ( + "WARNING: Observatory entry %s not found in database %s") + call pargstr (Memc[temp]) + call pargstr (Memc[fname]) + } + + # List database contents and try again + call seek (fd, BOF) + while (fscan (fd) != EOF) { + call gargwrd (Memc[key], SZ_FNAME) + call gargwrd (Memc[str], SZ_LINE) + call gargwrd (Memc[str], SZ_LINE) + if (nscan() < 3 || Memc[key] == '#') + next + if (streq (Memc[key], obskey)) { + call eprintf ("\n %s: ") + call pargstr (Memc[str]) + } else if (streq (Memc[key], "name")) + call eprintf (Memc[str]) + } + call seek (fd, BOF) + call eprintf ( + "\n obspars: Use parameters from OBSERVATORY task\n\n") + call flush (STDERR) + call clgstr ("observatory.override", Memc[obsname], SZ_LINE) + goto getobs_ + } + + # Create symbol table. + obs = stopen (Memc[obsname], LEN_INDEX, LEN_STAB, SZ_SBUF) + + # Read the file and enter the parameters in the symbol table. + sym = stenter (obs, Memc[key], SYMLEN) + call strcpy (Memc[obsname], OBSVAL(sym), SZ_OBSVAL) + while (fscan(fd) != EOF) { + call gargwrd (Memc[key], SZ_FNAME) + call gargwrd (Memc[str], SZ_LINE) + call gargwrd (Memc[str], SZ_LINE) + if (nscan() < 3 || Memc[key] == '#') + next + if (streq (Memc[key], obskey)) + break + sym = stenter (obs, Memc[key], SYMLEN) + call strcpy (Memc[str], OBSVAL(sym), SZ_OBSVAL) + } + } + + call close (fd) + call sfree (sp) + + return (obs) +end + + +# OBSCLOSE -- Close the observatory symbol table pointer. + +procedure obsclose (obs) + +pointer obs # Observatory symbol table pointer + +begin + if (obs != NULL) + call stclose (obs) +end + + +# OBSPARS -- Get parameter and if not found possibly get it from the +# observatory task + +pointer procedure obspars (obs, param) + +pointer obs # Observatory pointer +char param[ARB] # Parameter +pointer sym # Symbol table pointer + +bool streq() +pointer sp, str, stfind(), stenter() +double clgetd() + +begin + sym = stfind (obs, param) + if (sym != NULL) + return (sym) + + sym = stfind (obs, "observatory") + if (!streq (OBSVAL(sym), "obspars")) { + return (NULL) + } + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call sprintf (Memc[str], SZ_LINE, "observatory.%s") + call pargstr (param) + + if (streq (param, "name")) { + sym = stenter (obs, param, SYMLEN) + call clgstr (Memc[str], OBSVAL(sym), SZ_OBSVAL) + } else if (streq (param, "longitude")) { + sym = stenter (obs, param, SYMLEN) + call sprintf (OBSVAL(sym), SZ_OBSVAL, "%g") + call pargd (clgetd (Memc[str])) + } else if (streq (param, "latitude")) { + sym = stenter (obs, param, SYMLEN) + call sprintf (OBSVAL(sym), SZ_OBSVAL, "%g") + call pargd (clgetd (Memc[str])) + } else if (streq (param, "altitude")) { + sym = stenter (obs, param, SYMLEN) + call sprintf (OBSVAL(sym), SZ_OBSVAL, "%g") + call pargd (clgetd (Memc[str])) + } else if (streq (param, "timezone")) { + sym = stenter (obs, param, SYMLEN) + call sprintf (OBSVAL(sym), SZ_OBSVAL, "%g") + call pargd (clgetd (Memc[str])) + } + + call sfree (sp) + return (sym) +end + + + +# OBSLOG -- Log current observatory + +procedure obslog (obs, task, params, fd) + +pointer obs # Observatory symbol table pointer +char task[ARB] # Task name, image name, or other string +char params[ARB] # Parameters to log +int fd # File descriptor + +int ip, ctowrd() +pointer sym, obspars() +pointer sp, param + +begin + call smark (sp) + call salloc (param, SZ_FNAME, TY_CHAR) + + # Log task string and observatory name + sym = obspars (obs, "name") + if (sym == NULL) + sym = obspars (obs, "observatory") + + call fprintf (fd, "# ") + if (task[1] != EOS) { + call fprintf (fd, "%s: ") + call pargstr (task) + } + call fprintf (fd, "Observatory parameters for %s\n") + call pargstr (OBSVAL(sym)) + + for (ip=1; ctowrd (params, ip, Memc[param], SZ_FNAME) > 0;) { + sym = obspars (obs, Memc[param]) + if (sym == NULL) + next + call fprintf (fd, "#\t%s = %s\n") + call pargstr (Memc[param]) + call pargstr (OBSVAL(sym)) + } + call flush (fd) + + call sfree (sp) +end + + +# OBSGETI -- Get integer observatory parameter. + +int procedure obsgeti (obs, param) + +pointer obs # Observatory symbol table pointer +char param[ARB] # Observatory parameter + +int ip, ival, ctoi() +pointer sym, obspars() +errchk obspars + +begin + sym = obspars (obs, param) + if (sym == NULL) + call error (1, "OBSGETI: Observatory parameter not found") + ip = 1 + if (ctoi (OBSVAL(sym), ip, ival) <= 0) + call error (1, "OBSGETI: Observatory parameter not integer") + return (ival) +end + + +# OBSGETR -- Get real observatory parameter. + +real procedure obsgetr (obs, param) + +pointer obs # Observatory symbol table pointer +char param[ARB] # Observatory parameter + +int ip, ctor() +real rval +pointer sym, obspars() +errchk obspars + +begin + sym = obspars (obs, param) + if (sym == NULL) + call error (1, "OBSGETR: Observatory parameter not found") + ip = 1 + if (ctor (OBSVAL(sym), ip, rval) <= 0) + call error (1, "OBSGETR: Observatory parameter not real") + return (rval) +end + + +# OBSGETD -- Get double observatory parameter. + +double procedure obsgetd (obs, param) + +pointer obs # Observatory symbol table pointer +char param[ARB] # Observatory parameter + +int ip, ctod() +double dval +pointer sym, obspars() +errchk obspars + +begin + sym = obspars (obs, param) + if (sym == NULL) + call error (1, "OBSGETD: Observatory parameter not found") + ip = 1 + if (ctod (OBSVAL(sym), ip, dval) <= 0) + call error (1, "OBSGETD: Observatory parameter not double") + return (dval) +end + + +# OBSGSTR -- Get string valued observatory parameter. + +procedure obsgstr (obs, param, str, maxchar) + +pointer obs # Observatory symbol table pointer +char param[ARB] # Observatory parameter +char str[maxchar] # Observatory parameter value +int maxchar # Maximum characters for string + +pointer sym, obspars() +errchk obspars + +begin + sym = obspars (obs, param) + if (sym == NULL) + call error (1, "OBSGSTR: Observatory parameter not found") + call strcpy (OBSVAL(sym), str, maxchar) +end + + +# OBSIMOPEN - Open/reopen observatory for an image. +# Check if the OBSERVAT keyword is found. If found open/reopen the +# observatory. If not found open/reopen the default observatory. +# Return flags indicating a change in observatory and whether the +# observatory was defined in the image. + +procedure obsimopen (obs, im, observatory, verbose, newobs, obshead) + +pointer obs #U Observatory symbol table pointer +pointer im #I Image pointer +char observatory[ARB] #I Default observatory +int verbose #I Verbose? +bool newobs #O New observatory? +bool obshead #O Observatory found in header? + +bool strne() +pointer sp, observat, sym, obsvopen(), obspars() +errchk obsvopen + +begin + call smark (sp) + call salloc (observat, SZ_FNAME, TY_CHAR) + + if (verbose == YES) { + call imstats (im, IM_IMAGENAME, Memc[observat], SZ_FNAME) + call eprintf ("%s: ") + call pargstr (Memc[observat]) + } + + newobs = false + ifnoerr (call imgstr (im, "observat", Memc[observat], SZ_FNAME)) { + if (verbose == YES) { + call eprintf ("OBSERVAT = %s\n") + call pargstr (Memc[observat]) + } + + call strlwr (Memc[observat]) + if (obs == NULL) { + obs = obsvopen (Memc[observat], verbose) + newobs = true + } else { + sym = obspars (obs, "observatory") + if (strne (Memc[observat], OBSVAL(sym))) { + call obsclose (obs) + obs = obsvopen (Memc[observat], verbose) + newobs = true + } + } + obshead = true + } else { + if (verbose == YES) { + call eprintf ("No OBSERVAT keyword - using %s\n") + call pargstr (observatory) + } + + if (obs == NULL) { + obs = obsvopen (observatory, verbose) + newobs = true + } else { + sym = obspars (obs, "observatory") + if (strne (observatory, OBSVAL(sym))) { + call obsclose (obs) + obs = obsvopen (observatory, verbose) + newobs = true + } + } + obshead = false + } + + call sfree (sp) +end + + +# OBSINFO -- List observatory parameters + +procedure obsinfo (obs, fd) + +pointer obs # Observatory symbol table pointer +int fd # Output file descriptor + +pointer sym, name, obspars(), sthead(), stnext(), stname() +int stridxs() +bool streq() +errchk obspars +string obskey "observatory" + +begin + sym = obspars (obs, obskey) + call fprintf (fd, "\t%s = %s\n") + call pargstr (obskey) + call pargstr (OBSVAL(sym)) + + if (streq (OBSVAL(sym), "obspars")) { + sym = obspars (obs, "name") + sym = obspars (obs, "longitude") + sym = obspars (obs, "latitude") + sym = obspars (obs, "altitude") + sym = obspars (obs, "timezone") + } + + for (sym = sthead (obs); sym != NULL; sym = stnext (obs, sym)) { + name = stname (obs, sym) + if (streq (Memc[name], obskey)) + next + if (stridxs (" ", OBSVAL(sym)) > 0) + call fprintf (fd, "\t%s = '%s'\n") + else + call fprintf (fd, "\t%s = %s\n") + call pargstr (Memc[name]) + call pargstr (OBSVAL(sym)) + } +end diff --git a/pkg/xtools/peaks.x b/pkg/xtools/peaks.x new file mode 100644 index 00000000..dfad9abb --- /dev/null +++ b/pkg/xtools/peaks.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PEAKS -- find the peaks in an array of x and y points. +# The extrema in the input data points are found using extrema(xtools). +# The extrema are located to a precision of dx. +# The extrema with negative curvature (peaks) are selected and returned +# in the x array. The spline value is returned in the y array. The +# background is estimated by linear interpolation of the neighboring +# minima (extrema of positive curvature) to the position of the peak. +# The background is returned in the background array. The number of +# peaks found is returned as the function value. + +int procedure peaks (x, y, background, npts, dx) + +real x[npts], y[npts] # Input data points and output peaks +real background[npts] # Background estimate +int npts # Number of input data points +real dx # Precision of peak positions + +int i, j, k, npeaks, nextrema +pointer sp, a, b, c + +int extrema() +errchk salloc + +begin + nextrema = extrema (x, y, background, npts, dx) + + if (nextrema == 0) + return (0) + + # Allocate working storage + call smark (sp) + call salloc (a, nextrema, TY_REAL) + call salloc (b, nextrema, TY_REAL) + call salloc (c, nextrema, TY_REAL) + + npeaks = 0 + do i = 1, nextrema { + if (background[i] < 0.) { + Memr[a + npeaks] = x[i] + Memr[b + npeaks] = y[i] + for (j = i - 1; j > 0; j = j - 1) + if (background[j] > 0.) + break; + for (k = i + 1; k <= npts; k = k + 1) + if (background[k] > 0.) + break; + if ((j >= 1) && (k <= npts)) + Memr[c + npeaks] = + (y[k] - y[j]) / (x[k] - x[j]) * (x[i] - x[j]) + y[j] + else if (j >= 1) + Memr[c + npeaks] = y[j] + else if (k <= npts) + Memr[c + npeaks] = y[k] + else { + call sfree (sp) + call error (1, "No background points") + } + npeaks = npeaks + 1 + } + } + + call amovr (Memr[a], x, npeaks) + call amovr (Memr[b], y, npeaks) + call amovr (Memr[c], background, npeaks) + + call sfree (sp) + return (npeaks) +end diff --git a/pkg/xtools/ranges.par b/pkg/xtools/ranges.par new file mode 100644 index 00000000..57126d91 --- /dev/null +++ b/pkg/xtools/ranges.par @@ -0,0 +1,4 @@ +# Parameters for ranges task + +range_string,s,a,,,,Range string +test,*i,a,,,,Test value diff --git a/pkg/xtools/ranges.x b/pkg/xtools/ranges.x new file mode 100644 index 00000000..ce008b12 --- /dev/null +++ b/pkg/xtools/ranges.x @@ -0,0 +1,245 @@ +include <mach.h> +include <ctype.h> + +define FIRST 1 # Default starting range +define LAST MAX_INT # Default ending range +define STEP 1 # Default step +define EOLIST 0 # End of list + +# DECODE_RANGES -- Parse a string containing a list of integer numbers or +# ranges, delimited by either spaces or commas. Return as output a list +# of ranges defining a list of numbers, and the count of list numbers. +# Range limits must be positive nonnegative integers. ERR is returned as +# the function value if a conversion error occurs. The list of ranges is +# delimited by EOLIST. + +int procedure decode_ranges (range_string, ranges, max_ranges, nvalues) + +char range_string[ARB] # Range string to be decoded +int ranges[3, max_ranges] # Range array +int max_ranges # Maximum number of ranges +int nvalues # The number of values in the ranges + +int ip, nrange, first, last, step, ctoi() + +begin + ip = 1 + nvalues = 0 + + do nrange = 1, max_ranges - 1 { + # Defaults to all nonnegative integers + first = FIRST + last = LAST + step = STEP + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get first limit. + # Must be a number, '-', 'x', or EOS. If not return ERR. + if (range_string[ip] == EOS) { # end of list + if (nrange == 1) { + # Null string defaults + ranges[1, 1] = first + ranges[2, 1] = last + ranges[3, 1] = step + ranges[1, 2] = EOLIST + nvalues = MAX_INT + return (OK) + } else { + ranges[1, nrange] = EOLIST + return (OK) + } + } else if (range_string[ip] == '-') + ; + else if (range_string[ip] == 'x') + ; + else if (IS_DIGIT(range_string[ip])) { # ,n.. + if (ctoi (range_string, ip, first) == 0) + return (ERR) + } else + return (ERR) + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get last limit + # Must be '-', or 'x' otherwise last = first. + if (range_string[ip] == 'x') + ; + else if (range_string[ip] == '-') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, last) == 0) + return (ERR) + } else if (range_string[ip] == 'x') + ; + else + return (ERR) + } else + last = first + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get step. + # Must be 'x' or assume default step. + if (range_string[ip] == 'x') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, step) == 0) + ; + if (step == 0) + return (ERR) + } else if (range_string[ip] == '-') + ; + else + return (ERR) + } + + # Output the range triple. + ranges[1, nrange] = first + ranges[2, nrange] = last + ranges[3, nrange] = step + nvalues = nvalues + abs (last-first) / step + 1 + } + + return (ERR) # ran out of space +end + + +# GET_NEXT_NUMBER -- Given a list of ranges and the current file number, +# find and return the next file number. Selection is done in such a way +# that list numbers are always returned in monotonically increasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure get_next_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number+1 is anywhere in the list, that is the next number, + # otherwise the next number is the smallest number in the list which + # is greater than number+1. + + number = number + 1 + next_number = MAX_INT + + for (ip=1; ranges[ip] != EOLIST; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (step == 0) + call error (1, "Step size of zero in range list") + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder + step <= last) + next_number = number - remainder + step + } else if (first > number) + next_number = min (next_number, first) + } + + if (next_number == MAX_INT) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# GET_PREVIOUS_NUMBER -- Given a list of ranges and the current file number, +# find and return the previous file number. Selection is done in such a way +# that list numbers are always returned in monotonically decreasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure get_previous_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number-1 is anywhere in the list, that is the previous number, + # otherwise the previous number is the largest number in the list which + # is less than number-1. + + number = number - 1 + next_number = 0 + + for (ip=1; ranges[ip] != EOLIST; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (step == 0) + call error (1, "Step size of zero in range list") + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder >= first) + next_number = number - remainder + } else if (last < number) { + remainder = mod (last - first, step) + if (remainder == 0) + next_number = max (next_number, last) + else if (last - remainder >= first) + next_number = max (next_number, last - remainder) + } + } + + if (next_number == 0) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# IS_IN_RANGE -- Test number to see if it is in range. +# If the number is INDEFI then it is mapped to the maximum integer. + +bool procedure is_in_range (ranges, number) + +int ranges[ARB] # Range array +int number # Number to be tested against ranges + +int ip, first, last, step, num + +begin + if (IS_INDEFI (number)) + num = MAX_INT + else + num = number + + for (ip=1; ranges[ip] != EOLIST; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (num >= first && num <= last) + if (mod (num - first, step) == 0) + return (true) + } + + return (false) +end diff --git a/pkg/xtools/ranges/Revisions b/pkg/xtools/ranges/Revisions new file mode 100644 index 00000000..a249d529 --- /dev/null +++ b/pkg/xtools/ranges/Revisions @@ -0,0 +1,59 @@ +.help revisions Jun88 pkg.xtools.ranges +.nf +xtools$ranges/rgranges.x + The range parsing would fail for single numbers. (4/29/94, Valdes) + +xtools$ranges/rgranges.x +xtools$ranges/rgxranges.gx + Added @file capability. Rewrote the parsing logic. (10/9/91, Valdes) + +xtools$ranges/rgwtbin.gx + At least one point from each sample region must be included regardless + of the size of average. (6/14/89, Valdes) + +xtools$ranges/rgwtbin.gx + The remainder bin in a sample region must be at least + max (min (N, 3), (N+1)/2) except that a single bin may be any size. + (6/7/89, Valdes) + +xtools$ranges/rgencode.x, rginverse.x, rgnext.x, rgunion.x + Added some missing functionality to convert a range into a string, + to invert a range, to get the next higher member of a range (ala + xtools$ranges.x) and to take the union of two ranges. + (6/2/89, Seaman) + +xtools$ranges/rgintersect.x, rgmerge.x + Fixed bugs in handling overlapping ranges. (6/2/89, Seaman) + +xtools$ranges/rgxranges.gx + Numbers in scientific notation are now recognized. Based on report + from Ivo Busko. (3/1/89) + +xtools$ranges/rgwtbin.gx + The remainder bin in a sample region must be at least max (3, (N+1)/2) + except that a single bin may be any size. (1/23/89, Valdes) + +xtools$ranges/rgdump.x + +xtools$ranges/rgmerge.x + Valdes, May 4, 1987 + 1. Added a debugging procedure for dumping the ranges descriptor. + 2. Fixed a bug when merging overlapping ranges. + +xtools$ranges/rgbin.gx +xtools$ranges/rgwtbin.gx + Valdes, August 11, 1986 + 1. Since AMED$T no longer modifies the input array the temporary arrays + used to preserve the input array are no longer needed. + +xtools$ranges: Valdes, August 11, 1986 + 1. Reorganized package to have separate modules for each datatype. + This allows loading only the required procedures. + +xtools$ranges/rgwtbin.gx: Valdes, August 8, 1986 + 1. If all the weights were zero in a given range then a divide by zero + would result. A check against this was added. + +xtools$ranges: Valdes, March 13, 1986 + 1. The RANGES package has been converted to generic form. It is compiled + into both single and double precision procedures. +.endhelp diff --git a/pkg/xtools/ranges/mkpkg b/pkg/xtools/ranges/mkpkg new file mode 100644 index 00000000..9ec1673f --- /dev/null +++ b/pkg/xtools/ranges/mkpkg @@ -0,0 +1,49 @@ +# Library for the RANGES procedures. + +$checkout libxtools.a lib$ +$update libxtools.a +$checkin libxtools.a lib$ +$exit + +generic: + $set GEN = "$$generic -k -t rd" + $ifolder (rgbinr.x, rgbin.gx) $(GEN) rgbin.gx $endif + $ifolder (rgexcluder.x, rgexclude.gx) $(GEN) rgexclude.gx $endif + $ifolder (rggxmarkr.x, rggxmark.gx) $(GEN) rggxmark.gx $endif + $ifolder (rgpackr.x, rgpack.gx) $(GEN) rgpack.gx $endif + $ifolder (rgunpackr.x, rgunpack.gx) $(GEN) rgunpack.gx $endif + $ifolder (rgwtbinr.x, rgwtbin.gx) $(GEN) rgwtbin.gx $endif + $ifolder (rgxrangesr.x, rgxranges.gx) $(GEN) rgxranges.gx $endif + ; + +libxtools.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + rgbind.x <pkg/rg.h> + rgbinr.x <pkg/rg.h> + rgdump.x <pkg/rg.h> + rgencode.x <pkg/rg.h> + rgexcluded.x <pkg/rg.h> + rgexcluder.x <pkg/rg.h> + rgfree.x + rggxmarkd.x <gset.h> <pkg/rg.h> + rggxmarkr.x <gset.h> <pkg/rg.h> + rgindices.x <pkg/rg.h> + rginrange.x <pkg/rg.h> + rgintersect.x <pkg/rg.h> + rginverse.x <pkg/rg.h> + rgmerge.x <pkg/rg.h> + rgnext.x <mach.h> <pkg/rg.h> + rgorder.x <pkg/rg.h> + rgpackd.x <pkg/rg.h> + rgpackr.x <pkg/rg.h> + rgranges.x <ctype.h> <error.h> <pkg/rg.h> + rgunion.x <pkg/rg.h> + rgunpackd.x <pkg/rg.h> + rgunpackr.x <pkg/rg.h> + rgwindow.x <pkg/rg.h> + rgwtbind.x <pkg/rg.h> + rgwtbinr.x <pkg/rg.h> + rgxrangesd.x <ctype.h> <error.h> <pkg/rg.h> + rgxrangesr.x <ctype.h> <error.h> <pkg/rg.h> + ; diff --git a/pkg/xtools/ranges/rgbin.gx b/pkg/xtools/ranges/rgbin.gx new file mode 100644 index 00000000..f1133a1c --- /dev/null +++ b/pkg/xtools/ranges/rgbin.gx @@ -0,0 +1,75 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_BIN -- Average or median of data. +# +# The ranges are broken up into subranges of at most abs (nbin) points. The +# subranges are averaged if nbin > 1 and medianed if nbin < 1. +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_bin$t (rg, nbin, in, nin, out, nout) + +pointer rg # Ranges +int nbin # Maximum points in average or median +PIXEL in[nin] # Input array +int nin # Number of input points +PIXEL out[ARB] # Output array +int nout # Number of output points + +int i, j, k, n, npts, ntemp + +PIXEL asum$t(), amed$t() + +errchk rg_pack$t + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + # If the bin size is exactly one then move the selected input points + # to the output array. + + if (abs (nbin) == 1) { + call rg_pack$t (rg, in, out) + return + } + + # Determine the subranges and take the median or average. + + npts = abs (nbin) + ntemp = 0 + + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) > RG_X2(rg, i)) { + j = min (nin, RG_X1(rg, i)) + k = max (1, RG_X2(rg, i)) + while (j >= k) { + n = max (0, min (npts, j - k + 1)) + k = k - n + ntemp = ntemp + 1 + if (nbin > 0) + out[ntemp] = asum$t (in[k + 1], n) / n + else + out[ntemp] = amed$t (in[k+1], n) + } + } else { + j = max (1, RG_X1(rg, i)) + k = min (nin, RG_X2(rg, i)) + while (j <= k) { + n = max (0, min (npts, k - j + 1)) + ntemp = ntemp + 1 + if (nbin > 0) + out[ntemp] = asum$t (in[j], n) / n + else + out[ntemp] = amed$t (in[j], n) + j = j + n + } + } + } + + nout = ntemp +end diff --git a/pkg/xtools/ranges/rgbind.x b/pkg/xtools/ranges/rgbind.x new file mode 100644 index 00000000..16c66760 --- /dev/null +++ b/pkg/xtools/ranges/rgbind.x @@ -0,0 +1,75 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_BIN -- Average or median of data. +# +# The ranges are broken up into subranges of at most abs (nbin) points. The +# subranges are averaged if nbin > 1 and medianed if nbin < 1. +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_bind (rg, nbin, in, nin, out, nout) + +pointer rg # Ranges +int nbin # Maximum points in average or median +double in[nin] # Input array +int nin # Number of input points +double out[ARB] # Output array +int nout # Number of output points + +int i, j, k, n, npts, ntemp + +double asumd(), amedd() + +errchk rg_packd + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + # If the bin size is exactly one then move the selected input points + # to the output array. + + if (abs (nbin) == 1) { + call rg_packd (rg, in, out) + return + } + + # Determine the subranges and take the median or average. + + npts = abs (nbin) + ntemp = 0 + + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) > RG_X2(rg, i)) { + j = min (nin, RG_X1(rg, i)) + k = max (1, RG_X2(rg, i)) + while (j >= k) { + n = max (0, min (npts, j - k + 1)) + k = k - n + ntemp = ntemp + 1 + if (nbin > 0) + out[ntemp] = asumd (in[k + 1], n) / n + else + out[ntemp] = amedd (in[k+1], n) + } + } else { + j = max (1, RG_X1(rg, i)) + k = min (nin, RG_X2(rg, i)) + while (j <= k) { + n = max (0, min (npts, k - j + 1)) + ntemp = ntemp + 1 + if (nbin > 0) + out[ntemp] = asumd (in[j], n) / n + else + out[ntemp] = amedd (in[j], n) + j = j + n + } + } + } + + nout = ntemp +end diff --git a/pkg/xtools/ranges/rgbinr.x b/pkg/xtools/ranges/rgbinr.x new file mode 100644 index 00000000..81fb9f70 --- /dev/null +++ b/pkg/xtools/ranges/rgbinr.x @@ -0,0 +1,75 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_BIN -- Average or median of data. +# +# The ranges are broken up into subranges of at most abs (nbin) points. The +# subranges are averaged if nbin > 1 and medianed if nbin < 1. +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_binr (rg, nbin, in, nin, out, nout) + +pointer rg # Ranges +int nbin # Maximum points in average or median +real in[nin] # Input array +int nin # Number of input points +real out[ARB] # Output array +int nout # Number of output points + +int i, j, k, n, npts, ntemp + +real asumr(), amedr() + +errchk rg_packr + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + # If the bin size is exactly one then move the selected input points + # to the output array. + + if (abs (nbin) == 1) { + call rg_packr (rg, in, out) + return + } + + # Determine the subranges and take the median or average. + + npts = abs (nbin) + ntemp = 0 + + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) > RG_X2(rg, i)) { + j = min (nin, RG_X1(rg, i)) + k = max (1, RG_X2(rg, i)) + while (j >= k) { + n = max (0, min (npts, j - k + 1)) + k = k - n + ntemp = ntemp + 1 + if (nbin > 0) + out[ntemp] = asumr (in[k + 1], n) / n + else + out[ntemp] = amedr (in[k+1], n) + } + } else { + j = max (1, RG_X1(rg, i)) + k = min (nin, RG_X2(rg, i)) + while (j <= k) { + n = max (0, min (npts, k - j + 1)) + ntemp = ntemp + 1 + if (nbin > 0) + out[ntemp] = asumr (in[j], n) / n + else + out[ntemp] = amedr (in[j], n) + j = j + n + } + } + } + + nout = ntemp +end diff --git a/pkg/xtools/ranges/rgdump.x b/pkg/xtools/ranges/rgdump.x new file mode 100644 index 00000000..97c3a89b --- /dev/null +++ b/pkg/xtools/ranges/rgdump.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +include <pkg/rg.h> + +# RG_DUMP -- Dump the contents of a range structure. + +procedure rg_dump (rg) + +pointer rg # Ranges + +int i + +begin + if (rg == NULL) + call printf ("RG_DUMP: The range pointer is NULL\n") + else { + call printf ("RG_DUMP: NPTS = %d, NRGS = %d\n") + call pargi (RG_NPTS(rg)) + call pargi (RG_NRGS(rg)) + do i = 1, RG_NRGS(rg) { + call printf (" %4d - %4d\n") + call pargi (RG_X1(rg, i)) + call pargi (RG_X2(rg, i)) + } + } + call flush (STDOUT) +end diff --git a/pkg/xtools/ranges/rgencode.x b/pkg/xtools/ranges/rgencode.x new file mode 100644 index 00000000..ff0a0343 --- /dev/null +++ b/pkg/xtools/ranges/rgencode.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_ENCODE -- Encode a range structure into a string, return the +# number of characters that were written or ERR for string overflow. + +int procedure rg_encode (rg, outstr, maxch) + +pointer rg # First set of ranges +char outstr[maxch] # String to receive the ranges +int maxch # Maximum length of the string + +char tmpstr[SZ_LINE] +int i, outlen + +int strlen() + +begin + if (rg == NULL) + call error (0, "Range descriptor undefined") + + outlen = 0 + outstr[1] = EOS + + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) != RG_X2(rg, i)) { + call sprintf (tmpstr, maxch, "%d:%d,") + call pargi (RG_X1(rg, i)) + call pargi (RG_X2(rg, i)) + } else { + call sprintf (tmpstr, maxch, "%d,") + call pargi (RG_X1(rg, i)) + } + + outlen = outlen + strlen (tmpstr) + + if (outlen <= maxch) + call strcat (tmpstr, outstr, maxch) + else { + outstr[1] = EOS + return (ERR) + } + } + + # remove the last comma + + outstr[outlen] = EOS + outlen = outlen - 1 + + return (outlen) +end diff --git a/pkg/xtools/ranges/rgexclude.gx b/pkg/xtools/ranges/rgexclude.gx new file mode 100644 index 00000000..876e4ef7 --- /dev/null +++ b/pkg/xtools/ranges/rgexclude.gx @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_EXCLUDE -- Exclude points given by ranges. +# +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_exclude$t (rg, a, nin, b, nout) + +pointer rg # Ranges +PIXEL a[nin] # Input array +int nin # Number of input points +PIXEL b[ARB] # Output array +int nout # Number of output points + +int i, j, k, n, ntemp + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + if (RG_NRGS(rg) == 0) { + call amov$t (a[1], b[1], nin) + nout = nin + } else { + ntemp = 0 + + i = 1 + j = 1 + k = min (nin, min (RG_X1(rg, i), RG_X2(rg, i)) - 1) + n = max (0, k - j + 1) + call amov$t (a[j], b[ntemp+1], n) + ntemp = ntemp + n + + do i = 2, RG_NRGS(rg) { + j = max (1, max (RG_X1(rg, i-1), RG_X2(rg, i-1)) + 1) + k = min (nin, min (RG_X1(rg, i), RG_X2(rg, i)) - 1) + n = max (0, k - j + 1) + call amov$t (a[j], b[ntemp+1], n) + ntemp = ntemp + n + } + + i = RG_NRGS (rg) + j = max (1, max (RG_X1(rg, i), RG_X2(rg, i)) + 1) + k = nin + n = max (0, k - j + 1) + call amov$t (a[j], b[ntemp+1], n) + ntemp = ntemp + n + } + + nout = ntemp +end diff --git a/pkg/xtools/ranges/rgexcluded.x b/pkg/xtools/ranges/rgexcluded.x new file mode 100644 index 00000000..2d9ef823 --- /dev/null +++ b/pkg/xtools/ranges/rgexcluded.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_EXCLUDE -- Exclude points given by ranges. +# +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_excluded (rg, a, nin, b, nout) + +pointer rg # Ranges +double a[nin] # Input array +int nin # Number of input points +double b[ARB] # Output array +int nout # Number of output points + +int i, j, k, n, ntemp + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + if (RG_NRGS(rg) == 0) { + call amovd (a[1], b[1], nin) + nout = nin + } else { + ntemp = 0 + + i = 1 + j = 1 + k = min (nin, min (RG_X1(rg, i), RG_X2(rg, i)) - 1) + n = max (0, k - j + 1) + call amovd (a[j], b[ntemp+1], n) + ntemp = ntemp + n + + do i = 2, RG_NRGS(rg) { + j = max (1, max (RG_X1(rg, i-1), RG_X2(rg, i-1)) + 1) + k = min (nin, min (RG_X1(rg, i), RG_X2(rg, i)) - 1) + n = max (0, k - j + 1) + call amovd (a[j], b[ntemp+1], n) + ntemp = ntemp + n + } + + i = RG_NRGS (rg) + j = max (1, max (RG_X1(rg, i), RG_X2(rg, i)) + 1) + k = nin + n = max (0, k - j + 1) + call amovd (a[j], b[ntemp+1], n) + ntemp = ntemp + n + } + + nout = ntemp +end diff --git a/pkg/xtools/ranges/rgexcluder.x b/pkg/xtools/ranges/rgexcluder.x new file mode 100644 index 00000000..44cb90fe --- /dev/null +++ b/pkg/xtools/ranges/rgexcluder.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_EXCLUDE -- Exclude points given by ranges. +# +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_excluder (rg, a, nin, b, nout) + +pointer rg # Ranges +real a[nin] # Input array +int nin # Number of input points +real b[ARB] # Output array +int nout # Number of output points + +int i, j, k, n, ntemp + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + if (RG_NRGS(rg) == 0) { + call amovr (a[1], b[1], nin) + nout = nin + } else { + ntemp = 0 + + i = 1 + j = 1 + k = min (nin, min (RG_X1(rg, i), RG_X2(rg, i)) - 1) + n = max (0, k - j + 1) + call amovr (a[j], b[ntemp+1], n) + ntemp = ntemp + n + + do i = 2, RG_NRGS(rg) { + j = max (1, max (RG_X1(rg, i-1), RG_X2(rg, i-1)) + 1) + k = min (nin, min (RG_X1(rg, i), RG_X2(rg, i)) - 1) + n = max (0, k - j + 1) + call amovr (a[j], b[ntemp+1], n) + ntemp = ntemp + n + } + + i = RG_NRGS (rg) + j = max (1, max (RG_X1(rg, i), RG_X2(rg, i)) + 1) + k = nin + n = max (0, k - j + 1) + call amovr (a[j], b[ntemp+1], n) + ntemp = ntemp + n + } + + nout = ntemp +end diff --git a/pkg/xtools/ranges/rgfree.x b/pkg/xtools/ranges/rgfree.x new file mode 100644 index 00000000..8b2ab344 --- /dev/null +++ b/pkg/xtools/ranges/rgfree.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# RG_FREE -- Free ranges memory. + +procedure rg_free (rg) + +pointer rg # Ranges + +begin + if (rg != NULL) { + call mfree (rg, TY_STRUCT) + rg = NULL + } +end diff --git a/pkg/xtools/ranges/rggxmark.gx b/pkg/xtools/ranges/rggxmark.gx new file mode 100644 index 00000000..26108c98 --- /dev/null +++ b/pkg/xtools/ranges/rggxmark.gx @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <pkg/rg.h> + +# RG_GXMARK -- Mark x ranges. + +procedure rg_gxmark$t (gp, rstr, x, npts, pltype) + +pointer gp # GIO pointer +char rstr[ARB] # Range string +PIXEL x[npts] # Ordinates of graph +int npts # Number of data points +int pltype # Plot line type + +pointer rg +int i, pltype1 +real xl, xr, yb, yt, dy +real x1, x2, y1, y2, y3 + +int gstati(), stridxs() +pointer rg_xranges$t() + +begin + if (stridxs ("*", rstr) > 0) + return + + rg = rg_xranges$t (rstr, x, npts) + + pltype1 = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, pltype) + + call ggwind (gp, xl, xr, yb, yt) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if ((x1 > xl) && (x1 < xr)) + call gline (gp, x1, y1, x1, y2) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, x2, y1, x2, y2) + call gline (gp, x1, y3, x2, y3) + } + + call gseti (gp, G_PLTYPE, pltype1) + call rg_free (rg) +end diff --git a/pkg/xtools/ranges/rggxmarkd.x b/pkg/xtools/ranges/rggxmarkd.x new file mode 100644 index 00000000..82eb49db --- /dev/null +++ b/pkg/xtools/ranges/rggxmarkd.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <pkg/rg.h> + +# RG_GXMARK -- Mark x ranges. + +procedure rg_gxmarkd (gp, rstr, x, npts, pltype) + +pointer gp # GIO pointer +char rstr[ARB] # Range string +double x[npts] # Ordinates of graph +int npts # Number of data points +int pltype # Plot line type + +pointer rg +int i, pltype1 +real xl, xr, yb, yt, dy +real x1, x2, y1, y2, y3 + +int gstati(), stridxs() +pointer rg_xrangesd() + +begin + if (stridxs ("*", rstr) > 0) + return + + rg = rg_xrangesd (rstr, x, npts) + + pltype1 = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, pltype) + + call ggwind (gp, xl, xr, yb, yt) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if ((x1 > xl) && (x1 < xr)) + call gline (gp, x1, y1, x1, y2) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, x2, y1, x2, y2) + call gline (gp, x1, y3, x2, y3) + } + + call gseti (gp, G_PLTYPE, pltype1) + call rg_free (rg) +end diff --git a/pkg/xtools/ranges/rggxmarkr.x b/pkg/xtools/ranges/rggxmarkr.x new file mode 100644 index 00000000..ec0f63b8 --- /dev/null +++ b/pkg/xtools/ranges/rggxmarkr.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <gset.h> +include <pkg/rg.h> + +# RG_GXMARK -- Mark x ranges. + +procedure rg_gxmarkr (gp, rstr, x, npts, pltype) + +pointer gp # GIO pointer +char rstr[ARB] # Range string +real x[npts] # Ordinates of graph +int npts # Number of data points +int pltype # Plot line type + +pointer rg +int i, pltype1 +real xl, xr, yb, yt, dy +real x1, x2, y1, y2, y3 + +int gstati(), stridxs() +pointer rg_xrangesr() + +begin + if (stridxs ("*", rstr) > 0) + return + + rg = rg_xrangesr (rstr, x, npts) + + pltype1 = gstati (gp, G_PLTYPE) + call gseti (gp, G_PLTYPE, pltype) + + call ggwind (gp, xl, xr, yb, yt) + + dy = yt - yb + y1 = yb + dy / 100 + y2 = y1 + dy / 20 + y3 = (y1 + y2) / 2 + + do i = 1, RG_NRGS(rg) { + x1 = x[RG_X1(rg, i)] + x2 = x[RG_X2(rg, i)] + if ((x1 > xl) && (x1 < xr)) + call gline (gp, x1, y1, x1, y2) + if ((x2 > xl) && (x2 < xr)) + call gline (gp, x2, y1, x2, y2) + call gline (gp, x1, y3, x2, y3) + } + + call gseti (gp, G_PLTYPE, pltype1) + call rg_free (rg) +end diff --git a/pkg/xtools/ranges/rgindices.x b/pkg/xtools/ranges/rgindices.x new file mode 100644 index 00000000..48f1ec8f --- /dev/null +++ b/pkg/xtools/ranges/rgindices.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_INDICES -- Return the indices in the ranges. + +procedure rg_indices (rg, indices, npts, type) + +pointer rg # Ranges +pointer indices # Indices +int npts # Number of indices +int type # Data type of points + +int i, j, k, step + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + # Determine the number of range points. + + indices = NULL + npts = 0 + if (RG_NRGS (rg) == 0) + return + + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) > RG_X2(rg, i)) + npts = npts + RG_X1(rg, i) - RG_X2(rg, i) + 1 + else + npts = npts + RG_X2(rg, i) - RG_X1(rg, i) + 1 + } + + # Allocate the range points array. + + call malloc (indices, npts, type) + + # Set the range points. + + k = indices + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) > RG_X2(rg, i)) + step = -1 + else + step = 1 + + switch (type) { + case TY_SHORT: + do j = RG_X1(rg, i), RG_X2(rg, i), step { + Mems[k] = j + k = k + 1 + } + case TY_INT: + do j = RG_X1(rg, i), RG_X2(rg, i), step { + Memi[k] = j + k = k + 1 + } + case TY_LONG: + do j = RG_X1(rg, i), RG_X2(rg, i), step { + Meml[k] = j + k = k + 1 + } + case TY_REAL: + do j = RG_X1(rg, i), RG_X2(rg, i), step { + Memr[k] = j + k = k + 1 + } + case TY_DOUBLE: + do j = RG_X1(rg, i), RG_X2(rg, i), step { + Memd[k] = j + k = k + 1 + } + default: + call error (0, "rg_indices: Datatype not available") + } + } + + return +end diff --git a/pkg/xtools/ranges/rginrange.x b/pkg/xtools/ranges/rginrange.x new file mode 100644 index 00000000..7dd946ae --- /dev/null +++ b/pkg/xtools/ranges/rginrange.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_INRANGE -- Is value in the ranges? + +int procedure rg_inrange (rg, rval) + +pointer rg # Ranges +int rval # Range value to test + +int i + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + do i = 1, RG_NRGS(rg) { + if ((RG_X1(rg, i) <= RG_X2(rg, i)) && (rval >= RG_X1(rg, i)) && + (rval <= RG_X2(rg, i))) + return (YES) + else if ((rval >= RG_X2(rg, i)) && (rval <= RG_X1(rg, i))) + return (YES) + } + + return (NO) +end diff --git a/pkg/xtools/ranges/rgintersect.x b/pkg/xtools/ranges/rgintersect.x new file mode 100644 index 00000000..5e4e4390 --- /dev/null +++ b/pkg/xtools/ranges/rgintersect.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_INTERSECT -- Intersect two sets of ordered and merged ranges. + +pointer procedure rg_intersect (rg1, rg2) + +pointer rg1 # First set of ranges +pointer rg2 # Second set of ranges + +pointer rg3 # Pointer to intersection + +int i, j, k + +begin + # Error check the range pointers. + + if ((rg1 == NULL) || (rg2 == NULL)) + call error (0, "Range descriptor(s) undefined") + + # Allocate the range points array. + + k = RG_NRGS(rg1) + RG_NRGS(rg2) - 1 + call malloc (rg3, LEN_RG + 2 * max (1, k), TY_STRUCT) + + # Set the ranges. + + i = 1 + j = 1 + k = 0 + + while (i <= RG_NRGS(rg1) && j <= RG_NRGS(rg2)) { + if (RG_X2(rg1, i) < RG_X1(rg2, j)) + i = i + 1 + else if (RG_X2(rg2, j) < RG_X1(rg1, i)) + j = j + 1 + else { + k = k + 1 + RG_X1(rg3, k) = max (RG_X1(rg1, i), RG_X1(rg2, j)) + RG_X2(rg3, k) = min (RG_X2(rg1, i), RG_X2(rg2, j)) + + if (RG_X2(rg1, i) < RG_X2(rg2, j)) + i = i + 1 + else + j = j + 1 + } + } + + call realloc (rg3, LEN_RG + 2 * max (1, k), TY_STRUCT) + + RG_NRGS(rg3) = k + RG_NPTS(rg3) = 0 + do i = 1, RG_NRGS(rg3) + RG_NPTS(rg3) = RG_NPTS(rg3) + RG_X2(rg3, i) - RG_X1(rg3, i) + 1 + + return (rg3) +end diff --git a/pkg/xtools/ranges/rginverse.x b/pkg/xtools/ranges/rginverse.x new file mode 100644 index 00000000..869fde19 --- /dev/null +++ b/pkg/xtools/ranges/rginverse.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_INVERSE -- Invert a set of ordered and merged ranges. + +procedure rg_inverse (rg, rmin, rmax) + +pointer rg # RANGES pointer +int rmin # Minimum value of window +int rmax # Maximum value of window + +int i +pointer rgtmp + +pointer rg_window() + +begin + call malloc (rgtmp, LEN_RG + 2 * (RG_NRGS(rg) + 1), TY_STRUCT) + RG_NRGS(rgtmp) = RG_NRGS(rg) + 1 + + RG_X1(rgtmp, 1) = rmin + + do i = 1, RG_NRGS(rg) { + RG_X2(rgtmp, i) = RG_X1(rg, i) - 1 + RG_X1(rgtmp, i+1) = RG_X2(rg, i) + 1 + } + + RG_X2(rgtmp, RG_NRGS(rgtmp)) = rmax + + call rg_free (rg) + rg = rg_window (rgtmp, rmin, rmax) + call rg_free (rgtmp) +end diff --git a/pkg/xtools/ranges/rgmerge.x b/pkg/xtools/ranges/rgmerge.x new file mode 100644 index 00000000..2cb5034a --- /dev/null +++ b/pkg/xtools/ranges/rgmerge.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_MERGE -- Merge overlapping ranges in set of ordered ranges. + +procedure rg_merge (rg) + +pointer rg # Ranges + +int new, old + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + if (RG_NRGS(rg) == 0) + return + + # Eliminate overlapping ranges and count the number of new ranges. + + new = 1 + do old = 2, RG_NRGS(rg) + if (RG_X1(rg, old) > RG_X2(rg, new) + 1) { + new = new + 1 + RG_X1(rg, new) = RG_X1(rg, old) + RG_X2(rg, new) = RG_X2(rg, old) + } else + RG_X2(rg, new) = max (RG_X2(rg, old), RG_X2(rg, new)) + + call realloc (rg, LEN_RG + 2 * new, TY_STRUCT) + + RG_NPTS(rg) = 0 + RG_NRGS(rg) = new + do new = 1, RG_NRGS(rg) + RG_NPTS(rg) = RG_NPTS(rg) + RG_X2(rg, new) - RG_X1(rg, new) + 1 +end diff --git a/pkg/xtools/ranges/rgnext.x b/pkg/xtools/ranges/rgnext.x new file mode 100644 index 00000000..354ef813 --- /dev/null +++ b/pkg/xtools/ranges/rgnext.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <pkg/rg.h> + +# RG_NEXT -- Return the next value in a set of ordered and merged ranges. +# Number is set to the next value in the set of ranges or is unchanged +# (and EOF is returned) if there are no more values. + +int procedure rg_next (rg, number) + +pointer rg # RANGES pointer +int number # Both input and output parameter + +int next_number, i + +begin + next_number = number + 1 + + do i = 1, RG_NRGS(rg) + if (next_number > RG_X2(rg, i)) { + next + } else if (next_number < RG_X1(rg, i)) { + number = RG_X1(rg, i) + return (number) + } else { + number = next_number + return (number) + } + + return (EOF) +end diff --git a/pkg/xtools/ranges/rgorder.x b/pkg/xtools/ranges/rgorder.x new file mode 100644 index 00000000..7864ecb2 --- /dev/null +++ b/pkg/xtools/ranges/rgorder.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_ORDER -- Make all ranges increasing and order by the starting point. + +procedure rg_order (rg) + +pointer rg # Ranges + +int i, j, temp + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + # Make all ranges increasing. + + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) > RG_X2(rg, i)) { + temp = RG_X1(rg, i) + RG_X1(rg, i) = RG_X2(rg, i) + RG_X2(rg, i) = temp + } + } + + # Sort the ranges in increasing order. + + do i = 1, RG_NRGS(rg) - 1 { + do j = i + 1, RG_NRGS(rg) { + if (RG_X1(rg, i) > RG_X1(rg, j)) { + temp = RG_X1(rg, i) + RG_X1(rg, i) = RG_X1(rg, j) + RG_X1(rg, j) = temp + temp = RG_X2(rg, i) + RG_X2(rg, i) = RG_X2(rg, j) + RG_X2(rg, j) = temp + } + } + } +end diff --git a/pkg/xtools/ranges/rgpack.gx b/pkg/xtools/ranges/rgpack.gx new file mode 100644 index 00000000..d77a3a09 --- /dev/null +++ b/pkg/xtools/ranges/rgpack.gx @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_PACK -- Pack input data to include only points in the ranges. +# +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_pack$t (rg, a, b) + +pointer rg # Ranges +PIXEL a[ARB] # Input array +PIXEL b[ARB] # Output array + +int i, j, k, n + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range pointer undefined") + + j = 0 + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) > RG_X2(rg, i)) { + do k = RG_X1(rg, i), RG_X2(rg, i), -1 { + j = j + 1 + b[j] = a[k] + } + } else { + n = RG_X2(rg, i) - RG_X1(rg, i) + 1 + call amov$t (a[RG_X1(rg, i)], b[j + 1], n) + j = j + n + } + } +end diff --git a/pkg/xtools/ranges/rgpackd.x b/pkg/xtools/ranges/rgpackd.x new file mode 100644 index 00000000..a0889ec6 --- /dev/null +++ b/pkg/xtools/ranges/rgpackd.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_PACK -- Pack input data to include only points in the ranges. +# +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_packd (rg, a, b) + +pointer rg # Ranges +double a[ARB] # Input array +double b[ARB] # Output array + +int i, j, k, n + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range pointer undefined") + + j = 0 + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) > RG_X2(rg, i)) { + do k = RG_X1(rg, i), RG_X2(rg, i), -1 { + j = j + 1 + b[j] = a[k] + } + } else { + n = RG_X2(rg, i) - RG_X1(rg, i) + 1 + call amovd (a[RG_X1(rg, i)], b[j + 1], n) + j = j + n + } + } +end diff --git a/pkg/xtools/ranges/rgpackr.x b/pkg/xtools/ranges/rgpackr.x new file mode 100644 index 00000000..e01307a3 --- /dev/null +++ b/pkg/xtools/ranges/rgpackr.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_PACK -- Pack input data to include only points in the ranges. +# +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_packr (rg, a, b) + +pointer rg # Ranges +real a[ARB] # Input array +real b[ARB] # Output array + +int i, j, k, n + +begin + # Error check the range pointer. + + if (rg == NULL) + call error (0, "Range pointer undefined") + + j = 0 + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) > RG_X2(rg, i)) { + do k = RG_X1(rg, i), RG_X2(rg, i), -1 { + j = j + 1 + b[j] = a[k] + } + } else { + n = RG_X2(rg, i) - RG_X1(rg, i) + 1 + call amovr (a[RG_X1(rg, i)], b[j + 1], n) + j = j + n + } + } +end diff --git a/pkg/xtools/ranges/rgranges.x b/pkg/xtools/ranges/rgranges.x new file mode 100644 index 00000000..913fc2b9 --- /dev/null +++ b/pkg/xtools/ranges/rgranges.x @@ -0,0 +1,136 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <ctype.h> +include <pkg/rg.h> + +define NRGS 10 # Allocation size + +# RG_RANGES -- Parse a range string. Return a pointer to the ranges. + +pointer procedure rg_ranges (rstr, rmin, rmax) + +char rstr[ARB] # Range string +int rmin # Minimum value +int rmax # Maximum value +pointer rg # Range pointer + +int i, fd, strlen(), open(), getline() +pointer sp, str, ptr +errchk open, rg_add + +begin + call smark (sp) + call salloc (str, max (strlen (rstr), SZ_LINE), TY_CHAR) + call calloc (rg, LEN_RG, TY_STRUCT) + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Add range(s) + iferr { + if (Memc[str] == '@') { + fd = open (Memc[str+1], READ_ONLY, TEXT_FILE) + while (getline (fd, Memc[str]) != EOF) { + iferr (call rg_add (rg, Memc[str], rmin, rmax)) + call erract (EA_WARN) + } + call close (fd) + } else + call rg_add (rg, Memc[str], rmin, rmax) + } then + call erract (EA_WARN) + } + + call sfree (sp) + return (rg) +end + + +# RG_ADD -- Add a range + +procedure rg_add (rg, rstr, rmin, rmax) + +pointer rg # Range descriptor +char rstr[ARB] # Range string +int rmin # Minimum value +int rmax # Maximum value + +int i, j, nrgs, strlen(), ctoi() +int rval1, rval2 +pointer sp, str, ptr + +begin + call smark (sp) + call salloc (str, strlen (rstr), TY_CHAR) + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + if (rstr[i] == ':') + Memc[ptr] = ' ' + else + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Parse range + if (Memc[str] == '@') + call error (1, "Cannot nest @files") + else if (Memc[str] == '*') { + rval1 = rmin + rval2 = rmax + } else { + # Get range + j = 1 + if (ctoi (Memc[str], j, rval1) == 0) + call error (1, "Range syntax error") + if (ctoi (Memc[str], j, rval2) == 0) + rval2 = rval1 + } + + # Check limits. + j = rval1 + rval1 = min (j, rval2) + rval2 = max (j, rval2) + if (rval2 >= rmin && rval1 <= rmax) { + nrgs = RG_NRGS(rg) + if (mod (nrgs, NRGS) == 0) + call realloc (rg, LEN_RG+2*(nrgs+NRGS), TY_STRUCT) + nrgs = nrgs + 1 + RG_NRGS(rg) = nrgs + RG_X1(rg, nrgs) = max (rmin, rval1) + RG_X2(rg, nrgs) = min (rmax, rval2) + RG_NPTS(rg) = RG_NPTS(rg) + + abs (RG_X1(rg, nrgs) - RG_X2(rg, nrgs)) + 1 + } + } + + call sfree (sp) +end diff --git a/pkg/xtools/ranges/rgunion.x b/pkg/xtools/ranges/rgunion.x new file mode 100644 index 00000000..5b9dfa6f --- /dev/null +++ b/pkg/xtools/ranges/rgunion.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_UNION -- Find the union of two sets of ranges. + +pointer procedure rg_union (rg1, rg2) + +pointer rg1 # First set of ranges +pointer rg2 # Second set of ranges + +pointer rg3 # Pointer to union + +int i, j + +begin + # Error check the range pointers. + + if ((rg1 == NULL) || (rg2 == NULL)) + call error (0, "Range descriptor(s) undefined") + + # Allocate the range points array. + + i = RG_NRGS(rg1) + RG_NRGS(rg2) + call malloc (rg3, LEN_RG + 2 * max (1, i), TY_STRUCT) + + # Set the ranges. + + RG_NRGS(rg3) = i + RG_NPTS(rg3) = RG_NPTS(rg1) + RG_NPTS(rg2) + + j = 1 + do i = 1, RG_NRGS(rg1) { + RG_X1(rg3, j) = RG_X1(rg1, i) + RG_X2(rg3, j) = RG_X2(rg1, i) + j = j + 1 + } + do i = 1, RG_NRGS(rg2) { + RG_X1(rg3, j) = RG_X1(rg2, i) + RG_X2(rg3, j) = RG_X2(rg2, i) + j = j + 1 + } + + call rgorder (rg3) + call rgmerge (rg3) + + return (rg3) +end diff --git a/pkg/xtools/ranges/rgunpack.gx b/pkg/xtools/ranges/rgunpack.gx new file mode 100644 index 00000000..2b357ebb --- /dev/null +++ b/pkg/xtools/ranges/rgunpack.gx @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_UNPACK -- Unpack a packed array. +# +# There is no checking on the size of the arrays. The points in the +# unpacked array which are not covered by the packed array are left unchanged. +# The packed and unpacked arrays should not be the same. + +procedure rg_unpack$t (rg, packed, unpacked) + +pointer rg # Ranges +PIXEL packed[ARB] # Packed array +PIXEL unpacked[ARB] # Unpacked array + +int i, j, x1, x2, nx + +begin + if (rg == NULL) + call error (0, "Range descriptor undefined") + + j = 1 + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) < RG_X2(rg, i)) { + x1 = RG_X1(rg, i) + x2 = RG_X2(rg, i) + } else { + x1 = RG_X2(rg, i) + x2 = RG_X1(rg, i) + } + + nx = x2 - x1 + 1 + call amov$t (packed[j], unpacked[x1], nx) + j = j + nx + } +end diff --git a/pkg/xtools/ranges/rgunpackd.x b/pkg/xtools/ranges/rgunpackd.x new file mode 100644 index 00000000..2ce32fa2 --- /dev/null +++ b/pkg/xtools/ranges/rgunpackd.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_UNPACK -- Unpack a packed array. +# +# There is no checking on the size of the arrays. The points in the +# unpacked array which are not covered by the packed array are left unchanged. +# The packed and unpacked arrays should not be the same. + +procedure rg_unpackd (rg, packed, unpacked) + +pointer rg # Ranges +double packed[ARB] # Packed array +double unpacked[ARB] # Unpacked array + +int i, j, x1, x2, nx + +begin + if (rg == NULL) + call error (0, "Range descriptor undefined") + + j = 1 + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) < RG_X2(rg, i)) { + x1 = RG_X1(rg, i) + x2 = RG_X2(rg, i) + } else { + x1 = RG_X2(rg, i) + x2 = RG_X1(rg, i) + } + + nx = x2 - x1 + 1 + call amovd (packed[j], unpacked[x1], nx) + j = j + nx + } +end diff --git a/pkg/xtools/ranges/rgunpackr.x b/pkg/xtools/ranges/rgunpackr.x new file mode 100644 index 00000000..6c96f5f8 --- /dev/null +++ b/pkg/xtools/ranges/rgunpackr.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_UNPACK -- Unpack a packed array. +# +# There is no checking on the size of the arrays. The points in the +# unpacked array which are not covered by the packed array are left unchanged. +# The packed and unpacked arrays should not be the same. + +procedure rg_unpackr (rg, packed, unpacked) + +pointer rg # Ranges +real packed[ARB] # Packed array +real unpacked[ARB] # Unpacked array + +int i, j, x1, x2, nx + +begin + if (rg == NULL) + call error (0, "Range descriptor undefined") + + j = 1 + do i = 1, RG_NRGS(rg) { + if (RG_X1(rg, i) < RG_X2(rg, i)) { + x1 = RG_X1(rg, i) + x2 = RG_X2(rg, i) + } else { + x1 = RG_X2(rg, i) + x2 = RG_X1(rg, i) + } + + nx = x2 - x1 + 1 + call amovr (packed[j], unpacked[x1], nx) + j = j + nx + } +end diff --git a/pkg/xtools/ranges/rgwindow.x b/pkg/xtools/ranges/rgwindow.x new file mode 100644 index 00000000..fe495362 --- /dev/null +++ b/pkg/xtools/ranges/rgwindow.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_WINDOW -- Intersect a set of ordered and merged ranges with a window. + +pointer procedure rg_window (rg, rmin, rmax) + +pointer rg # Ranges +int rmin, rmax # Window + +pointer rgout # Pointer to windowed ranges + +int i, j + +begin + if (rg == NULL) + call error (0, "Range descriptor undefined") + + # Allocate the range points array. + + call malloc (rgout, LEN_RG + 2 * max (1, RG_NRGS(rg)), TY_STRUCT) + + # Set the windowed ranges. + + j = 0 + do i = 1, RG_NRGS(rg) { + if ((rmin <= RG_X2(rg, i)) && (rmax >= RG_X1(rg, i))) { + j = j + 1 + RG_X1(rgout, j) = max (rmin, RG_X1(rg, i)) + RG_X2(rgout, j) = min (rmax, RG_X2(rg, i)) + } + } + + call realloc (rgout, LEN_RG + 2 * max (1, j), TY_STRUCT) + RG_NRGS(rgout) = j + RG_NPTS(rgout) = 0 + do i = 1, RG_NRGS(rgout) + RG_NPTS(rgout) = RG_NPTS(rgout) + + abs (RG_X1(rgout, i) - RG_X2(rgout, i)) + 1 + + return (rgout) +end diff --git a/pkg/xtools/ranges/rgwtbin.gx b/pkg/xtools/ranges/rgwtbin.gx new file mode 100644 index 00000000..711dbf1e --- /dev/null +++ b/pkg/xtools/ranges/rgwtbin.gx @@ -0,0 +1,112 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_WTBIN -- Weighted average or median of data. +# +# The ranges are broken up into subranges of at most abs (nbin) points and a +# minimum of max (3, (abs(nbin)+1)/2) (though always at least one bin). The +# subranges are weighted averaged if nbin > 1 and medianed if nbin < 1. +# The output weights are the sum of the weights for each subrange. +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_wtbin$t (rg, nbin, in, wtin, nin, out, wtout, nout) + +pointer rg # Ranges +int nbin # Maximum points in average or median +PIXEL in[nin] # Input array +PIXEL wtin[nin] # Input weights +int nin # Number of input points +PIXEL out[ARB] # Output array +PIXEL wtout[ARB] # Output weights +int nout # Number of output points + +int i, j, k, l, n, npts, ntemp, nsample + +PIXEL asum$t(), amed$t() + +errchk rg_pack$t + +begin + # Check for a null set of ranges. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + # If the bin size is exactly one then move the selected input points + # to the output array. + + if (abs (nbin) < 2) { + call rg_pack$t (rg, in, out) + call rg_pack$t (rg, wtin, wtout) + nout = RG_NPTS(rg) + return + } + + # Determine the subranges and take the median or average. + + npts = abs (nbin) + ntemp = 0 + + do i = 1, RG_NRGS(rg) { + nsample = 0 + if (RG_X1(rg, i) > RG_X2(rg, i)) { + j = min (nin, RG_X1(rg, i)) + k = max (1, RG_X2(rg, i)) + while (j >= k) { + n = max (0, min (npts, j - k + 1)) + if (nsample > 0 && n < max (min (npts, 3), (npts+1)/2)) + break + k = k - n + nsample = nsample + 1 + ntemp = ntemp + 1 + wtout[ntemp] = asum$t (wtin[k + 1], n) + if (nbin > 0) { + if (wtout[ntemp] != 0.) { + out[ntemp] = 0. + do l = k + 1, k + n + out[ntemp] = out[ntemp] + in[l] * wtin[l] + out[ntemp] = out[ntemp] / wtout[ntemp] + } else { + out[ntemp] = 0. + do l = k + 1, k + n + out[ntemp] = out[ntemp] + in[l] + out[ntemp] = out[ntemp] / n + } + } else { + out[ntemp] = amed$t (in[k+1], n) + } + } + } else { + j = max (1, RG_X1(rg, i)) + k = min (nin, RG_X2(rg, i)) + while (j <= k) { + n = max (0, min (npts, k - j + 1)) + if (nsample > 0 && n < max (min (npts, 3), (npts+1)/2)) + break + nsample = nsample + 1 + ntemp = ntemp + 1 + wtout[ntemp] = asum$t (wtin[j], n) + if (nbin > 0) { + if (wtout[ntemp] != 0.) { + out[ntemp] = 0. + do l = j, j + n - 1 + out[ntemp] = out[ntemp] + in[l] * wtin[l] + out[ntemp] = out[ntemp] / wtout[ntemp] + } else { + out[ntemp] = 0. + do l = j, j + n - 1 + out[ntemp] = out[ntemp] + in[l] + out[ntemp] = out[ntemp] / n + } + } else { + out[ntemp] = amed$t (in[j], n) + } + j = j + n + } + } + } + + nout = ntemp +end diff --git a/pkg/xtools/ranges/rgwtbind.x b/pkg/xtools/ranges/rgwtbind.x new file mode 100644 index 00000000..82adeba5 --- /dev/null +++ b/pkg/xtools/ranges/rgwtbind.x @@ -0,0 +1,112 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_WTBIN -- Weighted average or median of data. +# +# The ranges are broken up into subranges of at most abs (nbin) points and a +# minimum of max (3, (abs(nbin)+1)/2) (though always at least one bin). The +# subranges are weighted averaged if nbin > 1 and medianed if nbin < 1. +# The output weights are the sum of the weights for each subrange. +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_wtbind (rg, nbin, in, wtin, nin, out, wtout, nout) + +pointer rg # Ranges +int nbin # Maximum points in average or median +double in[nin] # Input array +double wtin[nin] # Input weights +int nin # Number of input points +double out[ARB] # Output array +double wtout[ARB] # Output weights +int nout # Number of output points + +int i, j, k, l, n, npts, ntemp, nsample + +double asumd(), amedd() + +errchk rg_packd + +begin + # Check for a null set of ranges. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + # If the bin size is exactly one then move the selected input points + # to the output array. + + if (abs (nbin) < 2) { + call rg_packd (rg, in, out) + call rg_packd (rg, wtin, wtout) + nout = RG_NPTS(rg) + return + } + + # Determine the subranges and take the median or average. + + npts = abs (nbin) + ntemp = 0 + + do i = 1, RG_NRGS(rg) { + nsample = 0 + if (RG_X1(rg, i) > RG_X2(rg, i)) { + j = min (nin, RG_X1(rg, i)) + k = max (1, RG_X2(rg, i)) + while (j >= k) { + n = max (0, min (npts, j - k + 1)) + if (nsample > 0 && n < max (min (npts, 3), (npts+1)/2)) + break + k = k - n + nsample = nsample + 1 + ntemp = ntemp + 1 + wtout[ntemp] = asumd (wtin[k + 1], n) + if (nbin > 0) { + if (wtout[ntemp] != 0.) { + out[ntemp] = 0. + do l = k + 1, k + n + out[ntemp] = out[ntemp] + in[l] * wtin[l] + out[ntemp] = out[ntemp] / wtout[ntemp] + } else { + out[ntemp] = 0. + do l = k + 1, k + n + out[ntemp] = out[ntemp] + in[l] + out[ntemp] = out[ntemp] / n + } + } else { + out[ntemp] = amedd (in[k+1], n) + } + } + } else { + j = max (1, RG_X1(rg, i)) + k = min (nin, RG_X2(rg, i)) + while (j <= k) { + n = max (0, min (npts, k - j + 1)) + if (nsample > 0 && n < max (min (npts, 3), (npts+1)/2)) + break + nsample = nsample + 1 + ntemp = ntemp + 1 + wtout[ntemp] = asumd (wtin[j], n) + if (nbin > 0) { + if (wtout[ntemp] != 0.) { + out[ntemp] = 0. + do l = j, j + n - 1 + out[ntemp] = out[ntemp] + in[l] * wtin[l] + out[ntemp] = out[ntemp] / wtout[ntemp] + } else { + out[ntemp] = 0. + do l = j, j + n - 1 + out[ntemp] = out[ntemp] + in[l] + out[ntemp] = out[ntemp] / n + } + } else { + out[ntemp] = amedd (in[j], n) + } + j = j + n + } + } + } + + nout = ntemp +end diff --git a/pkg/xtools/ranges/rgwtbinr.x b/pkg/xtools/ranges/rgwtbinr.x new file mode 100644 index 00000000..a4be8485 --- /dev/null +++ b/pkg/xtools/ranges/rgwtbinr.x @@ -0,0 +1,112 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/rg.h> + +# RG_WTBIN -- Weighted average or median of data. +# +# The ranges are broken up into subranges of at most abs (nbin) points and a +# minimum of max (3, (abs(nbin)+1)/2) (though always at least one bin). The +# subranges are weighted averaged if nbin > 1 and medianed if nbin < 1. +# The output weights are the sum of the weights for each subrange. +# The output array must be large enough to contain the desired points. +# If the ranges are merged then the input and output arrays may be the same. + +procedure rg_wtbinr (rg, nbin, in, wtin, nin, out, wtout, nout) + +pointer rg # Ranges +int nbin # Maximum points in average or median +real in[nin] # Input array +real wtin[nin] # Input weights +int nin # Number of input points +real out[ARB] # Output array +real wtout[ARB] # Output weights +int nout # Number of output points + +int i, j, k, l, n, npts, ntemp, nsample + +real asumr(), amedr() + +errchk rg_packr + +begin + # Check for a null set of ranges. + + if (rg == NULL) + call error (0, "Range descriptor undefined") + + # If the bin size is exactly one then move the selected input points + # to the output array. + + if (abs (nbin) < 2) { + call rg_packr (rg, in, out) + call rg_packr (rg, wtin, wtout) + nout = RG_NPTS(rg) + return + } + + # Determine the subranges and take the median or average. + + npts = abs (nbin) + ntemp = 0 + + do i = 1, RG_NRGS(rg) { + nsample = 0 + if (RG_X1(rg, i) > RG_X2(rg, i)) { + j = min (nin, RG_X1(rg, i)) + k = max (1, RG_X2(rg, i)) + while (j >= k) { + n = max (0, min (npts, j - k + 1)) + if (nsample > 0 && n < max (min (npts, 3), (npts+1)/2)) + break + k = k - n + nsample = nsample + 1 + ntemp = ntemp + 1 + wtout[ntemp] = asumr (wtin[k + 1], n) + if (nbin > 0) { + if (wtout[ntemp] != 0.) { + out[ntemp] = 0. + do l = k + 1, k + n + out[ntemp] = out[ntemp] + in[l] * wtin[l] + out[ntemp] = out[ntemp] / wtout[ntemp] + } else { + out[ntemp] = 0. + do l = k + 1, k + n + out[ntemp] = out[ntemp] + in[l] + out[ntemp] = out[ntemp] / n + } + } else { + out[ntemp] = amedr (in[k+1], n) + } + } + } else { + j = max (1, RG_X1(rg, i)) + k = min (nin, RG_X2(rg, i)) + while (j <= k) { + n = max (0, min (npts, k - j + 1)) + if (nsample > 0 && n < max (min (npts, 3), (npts+1)/2)) + break + nsample = nsample + 1 + ntemp = ntemp + 1 + wtout[ntemp] = asumr (wtin[j], n) + if (nbin > 0) { + if (wtout[ntemp] != 0.) { + out[ntemp] = 0. + do l = j, j + n - 1 + out[ntemp] = out[ntemp] + in[l] * wtin[l] + out[ntemp] = out[ntemp] / wtout[ntemp] + } else { + out[ntemp] = 0. + do l = j, j + n - 1 + out[ntemp] = out[ntemp] + in[l] + out[ntemp] = out[ntemp] / n + } + } else { + out[ntemp] = amedr (in[j], n) + } + j = j + n + } + } + } + + nout = ntemp +end diff --git a/pkg/xtools/ranges/rgxranges.gx b/pkg/xtools/ranges/rgxranges.gx new file mode 100644 index 00000000..7a779925 --- /dev/null +++ b/pkg/xtools/ranges/rgxranges.gx @@ -0,0 +1,162 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <ctype.h> +include <pkg/rg.h> + +define NRGS 10 # Allocation size + +# RG_XRANGES -- Parse a range string corrsponding to a real set of values. +# Return a pointer to the ranges. + +pointer procedure rg_xranges$t (rstr, rvals, npts) + +char rstr[ARB] # Range string +PIXEL rvals[npts] # Range values (sorted) +int npts # Number of range values +pointer rg # Range pointer + +int i, fd, strlen(), open(), getline() +pointer sp, str, ptr +errchk open, rg_xadd$t + +begin + # Check for valid arguments + if (npts < 1) + call error (0, "No data points for range determination") + + call smark (sp) + call salloc (str, max (strlen (rstr), SZ_LINE), TY_CHAR) + call calloc (rg, LEN_RG, TY_STRUCT) + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Add range(s) + iferr { + if (Memc[str] == '@') { + fd = open (Memc[str+1], READ_ONLY, TEXT_FILE) + while (getline (fd, Memc[str]) != EOF) { + iferr (call rg_xadd$t (rg, Memc[str], rvals, npts)) + call erract (EA_WARN) + } + call close (fd) + } else + call rg_xadd$t (rg, Memc[str], rvals, npts) + } then + call erract (EA_WARN) + } + + call sfree (sp) + return (rg) +end + + +# RG_XADD -- Add a range + +procedure rg_xadd$t (rg, rstr, rvals, npts) + +pointer rg # Range descriptor +char rstr[ARB] # Range string +PIXEL rvals[npts] # Range values (sorted) +int npts # Number of range values + +int i, j, k, nrgs, strlen(), cto$t() +PIXEL rval1, rval2, a1, b1, a2, b2 +pointer sp, str, ptr + +begin + call smark (sp) + call salloc (str, strlen (rstr), TY_CHAR) + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + if (rstr[i] == ':') + Memc[ptr] = ' ' + else + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Parse range + if (Memc[str] == '@') + call error (1, "Cannot nest @files") + else if (Memc[str] == '*') { + rval1 = rvals[1] + rval2 = rvals[npts] + } else { + # Get range + j = 1 + if (cto$t (Memc[str], j, rval1) == 0) + call error (1, "Range syntax error") + rval2 = rval1 + if (cto$t (Memc[str], j, rval2) == 0) + ; + } + + # Check limits and find indices into rval array + a1 = min (rval1, rval2) + b1 = max (rval1, rval2) + a2 = min (rvals[1], rvals[npts]) + b2 = max (rvals[1], rvals[npts]) + if ((b1 >= a2) && (a1 <= b2)) { + a1 = max (a2, min (b2, a1)) + b1 = max (a2, min (b2, b1)) + if (rvals[1] <= rvals[npts]) { + for (k = 1; (k <= npts) && (rvals[k] < a1); k = k + 1) + ; + for (j = k; (j <= npts) && (rvals[j] <= b1); j = j + 1) + ; + j = j - 1 + } else { + for (k = 1; (k <= npts) && (rvals[k] > b1); k = k + 1) + ; + for (j = k; (j <= npts) && (rvals[j] >= a1); j = j + 1) + ; + j = j - 1 + } + + # Add range + if (k <= j) { + nrgs = RG_NRGS(rg) + if (mod (nrgs, NRGS) == 0) + call realloc (rg, LEN_RG+2*(nrgs+NRGS), TY_STRUCT) + nrgs = nrgs + 1 + RG_NRGS(rg) = nrgs + RG_X1(rg, nrgs) = k + RG_X2(rg, nrgs) = j + RG_NPTS(rg) = RG_NPTS(rg) + + RG_X1(rg, nrgs) - RG_X2(rg, nrgs) + 1 + } + } + } + + call sfree (sp) +end diff --git a/pkg/xtools/ranges/rgxranges1.gx b/pkg/xtools/ranges/rgxranges1.gx new file mode 100644 index 00000000..b019e47c --- /dev/null +++ b/pkg/xtools/ranges/rgxranges1.gx @@ -0,0 +1,146 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <pkg/rg.h> + +# RG_XRANGES -- Parse a range string corrsponding to a real set of values. +# Return a pointer to the ranges. + +pointer procedure rg_xranges$t (rstr, rvals, npts) + +char rstr[ARB] # Range string +PIXEL rvals[npts] # Range values (sorted) +int npts # Number of range values + +pointer rg +int i, j, k, nrgs +PIXEL rval1, rval2, a, b + +int cto$t() + +begin + # Check for valid arguments. + + if (npts < 1) + call error (0, "No data points for range determination") + + # Check for a valid string and determine the number of ranges. + + i = 1 + nrgs = 0 + + while (rstr[i] != EOS) { + + # Skip delimiters + while (IS_WHITE(rstr[i]) || (rstr[i] == ',') || (rstr[i]=='\n')) + i = i + 1 + + # Check for EOS. + + if (rstr[i] == EOS) + break + + # First character must be a *, -, ., or digit. + + if ((rstr[i] == '*') || (rstr[i] == '-') || (rstr[i] == '.') || + IS_DIGIT(rstr[i])) { + i = i + 1 + nrgs = nrgs + 1 + + # Remaining characters must be :, -, ., E, D, e, d, or digits. + # Replace : with ! to avoid sexigesimal interpretation. + + while ((rstr[i]==':') || (rstr[i]=='-') || (rstr[i]=='.') || + (rstr[i]=='E') || (rstr[i]=='D') || + (rstr[i]=='e') || (rstr[i]=='d') || + IS_DIGIT(rstr[i])) { + if (rstr[i] == ':') + rstr[i] = '!' + i = i + 1 + } + } else + call error (0, "Syntax error in range string") + } + + # Allocate memory for the ranges. + + call malloc (rg, LEN_RG + 2 * max (1, nrgs), TY_STRUCT) + + # Rescan the string and set the ranges. + + i = 1 + nrgs = 0 + + while (rstr[i] != EOS) { + + # Skip delimiters. + while (IS_WHITE(rstr[i]) || (rstr[i]==',') || (rstr[i]=='\n')) + i = i + 1 + + # Check for EOS. + + if (rstr[i] == EOS) + break + + # If first character is * then set range to full range. + # Otherwise parse the range. + + if (rstr[i] == '*') { + i = i + 1 + rval1 = rvals[1] + rval2 = rvals[npts] + + } else { + # First digit is starting value. + if (cto$t (rstr, i, rval1) == 0) { + nrgs = 0 + break + } + rval2 = rval1 + + # Check for an ending value for the range and restore ':'. + if (rstr[i] == '!') { + rstr[i] = ':' + i = i + 1 + if (cto$t (rstr, i, rval2) == 0) { + nrgs = 0 + break + } + } + } + + # Check limits. + + a = min (rval1, rval2) + b = max (rval1, rval2) + if ((b >= rvals[1]) && (a <= rvals[npts])) { + rval1 = max (rvals[1], min (rvals[npts], rval1)) + rval2 = max (rvals[1], min (rvals[npts], rval2)) + a = min (rval1, rval2) + b = max (rval1, rval2) + for (k = 1; (k <= npts) && (rvals[k] < a); k = k + 1) + ; + for (j = k; (j <= npts) && (rvals[j] <= b); j = j + 1) + ; + j = j - 1 + if (k <= j) { + nrgs = nrgs + 1 + if (rval1 <= rval2) { + RG_X1(rg, nrgs) = k + RG_X2(rg, nrgs) = j + } else { + RG_X1(rg, nrgs) = j + RG_X2(rg, nrgs) = k + } + } + } + } + + RG_NRGS(rg) = nrgs + RG_NPTS(rg) = 0 + do i = 1, RG_NRGS(rg) + RG_NPTS(rg) = RG_NPTS(rg) + + abs (RG_X1(rg, i) - RG_X2(rg, i)) + 1 + + return (rg) +end diff --git a/pkg/xtools/ranges/rgxrangesd.x b/pkg/xtools/ranges/rgxrangesd.x new file mode 100644 index 00000000..f9de6c32 --- /dev/null +++ b/pkg/xtools/ranges/rgxrangesd.x @@ -0,0 +1,162 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <ctype.h> +include <pkg/rg.h> + +define NRGS 10 # Allocation size + +# RG_XRANGES -- Parse a range string corrsponding to a real set of values. +# Return a pointer to the ranges. + +pointer procedure rg_xrangesd (rstr, rvals, npts) + +char rstr[ARB] # Range string +double rvals[npts] # Range values (sorted) +int npts # Number of range values +pointer rg # Range pointer + +int i, fd, strlen(), open(), getline() +pointer sp, str, ptr +errchk open, rg_xaddd + +begin + # Check for valid arguments + if (npts < 1) + call error (0, "No data points for range determination") + + call smark (sp) + call salloc (str, max (strlen (rstr), SZ_LINE), TY_CHAR) + call calloc (rg, LEN_RG, TY_STRUCT) + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Add range(s) + iferr { + if (Memc[str] == '@') { + fd = open (Memc[str+1], READ_ONLY, TEXT_FILE) + while (getline (fd, Memc[str]) != EOF) { + iferr (call rg_xaddd (rg, Memc[str], rvals, npts)) + call erract (EA_WARN) + } + call close (fd) + } else + call rg_xaddd (rg, Memc[str], rvals, npts) + } then + call erract (EA_WARN) + } + + call sfree (sp) + return (rg) +end + + +# RG_XADD -- Add a range + +procedure rg_xaddd (rg, rstr, rvals, npts) + +pointer rg # Range descriptor +char rstr[ARB] # Range string +double rvals[npts] # Range values (sorted) +int npts # Number of range values + +int i, j, k, nrgs, strlen(), ctod() +double rval1, rval2, a1, b1, a2, b2 +pointer sp, str, ptr + +begin + call smark (sp) + call salloc (str, strlen (rstr), TY_CHAR) + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + if (rstr[i] == ':') + Memc[ptr] = ' ' + else + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Parse range + if (Memc[str] == '@') + call error (1, "Cannot nest @files") + else if (Memc[str] == '*') { + rval1 = rvals[1] + rval2 = rvals[npts] + } else { + # Get range + j = 1 + if (ctod (Memc[str], j, rval1) == 0) + call error (1, "Range syntax error") + rval2 = rval1 + if (ctod (Memc[str], j, rval2) == 0) + ; + } + + # Check limits and find indices into rval array + a1 = min (rval1, rval2) + b1 = max (rval1, rval2) + a2 = min (rvals[1], rvals[npts]) + b2 = max (rvals[1], rvals[npts]) + if ((b1 >= a2) && (a1 <= b2)) { + a1 = max (a2, min (b2, a1)) + b1 = max (a2, min (b2, b1)) + if (rvals[1] <= rvals[npts]) { + for (k = 1; (k <= npts) && (rvals[k] < a1); k = k + 1) + ; + for (j = k; (j <= npts) && (rvals[j] <= b1); j = j + 1) + ; + j = j - 1 + } else { + for (k = 1; (k <= npts) && (rvals[k] > b1); k = k + 1) + ; + for (j = k; (j <= npts) && (rvals[j] >= a1); j = j + 1) + ; + j = j - 1 + } + + # Add range + if (k <= j) { + nrgs = RG_NRGS(rg) + if (mod (nrgs, NRGS) == 0) + call realloc (rg, LEN_RG+2*(nrgs+NRGS), TY_STRUCT) + nrgs = nrgs + 1 + RG_NRGS(rg) = nrgs + RG_X1(rg, nrgs) = k + RG_X2(rg, nrgs) = j + RG_NPTS(rg) = RG_NPTS(rg) + + RG_X1(rg, nrgs) - RG_X2(rg, nrgs) + 1 + } + } + } + + call sfree (sp) +end diff --git a/pkg/xtools/ranges/rgxrangesr.x b/pkg/xtools/ranges/rgxrangesr.x new file mode 100644 index 00000000..425abf04 --- /dev/null +++ b/pkg/xtools/ranges/rgxrangesr.x @@ -0,0 +1,162 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <ctype.h> +include <pkg/rg.h> + +define NRGS 10 # Allocation size + +# RG_XRANGES -- Parse a range string corrsponding to a real set of values. +# Return a pointer to the ranges. + +pointer procedure rg_xrangesr (rstr, rvals, npts) + +char rstr[ARB] # Range string +real rvals[npts] # Range values (sorted) +int npts # Number of range values +pointer rg # Range pointer + +int i, fd, strlen(), open(), getline() +pointer sp, str, ptr +errchk open, rg_xaddr + +begin + # Check for valid arguments + if (npts < 1) + call error (0, "No data points for range determination") + + call smark (sp) + call salloc (str, max (strlen (rstr), SZ_LINE), TY_CHAR) + call calloc (rg, LEN_RG, TY_STRUCT) + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Add range(s) + iferr { + if (Memc[str] == '@') { + fd = open (Memc[str+1], READ_ONLY, TEXT_FILE) + while (getline (fd, Memc[str]) != EOF) { + iferr (call rg_xaddr (rg, Memc[str], rvals, npts)) + call erract (EA_WARN) + } + call close (fd) + } else + call rg_xaddr (rg, Memc[str], rvals, npts) + } then + call erract (EA_WARN) + } + + call sfree (sp) + return (rg) +end + + +# RG_XADD -- Add a range + +procedure rg_xaddr (rg, rstr, rvals, npts) + +pointer rg # Range descriptor +char rstr[ARB] # Range string +real rvals[npts] # Range values (sorted) +int npts # Number of range values + +int i, j, k, nrgs, strlen(), ctor() +real rval1, rval2, a1, b1, a2, b2 +pointer sp, str, ptr + +begin + call smark (sp) + call salloc (str, strlen (rstr), TY_CHAR) + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + if (rstr[i] == ':') + Memc[ptr] = ' ' + else + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Parse range + if (Memc[str] == '@') + call error (1, "Cannot nest @files") + else if (Memc[str] == '*') { + rval1 = rvals[1] + rval2 = rvals[npts] + } else { + # Get range + j = 1 + if (ctor (Memc[str], j, rval1) == 0) + call error (1, "Range syntax error") + rval2 = rval1 + if (ctor (Memc[str], j, rval2) == 0) + ; + } + + # Check limits and find indices into rval array + a1 = min (rval1, rval2) + b1 = max (rval1, rval2) + a2 = min (rvals[1], rvals[npts]) + b2 = max (rvals[1], rvals[npts]) + if ((b1 >= a2) && (a1 <= b2)) { + a1 = max (a2, min (b2, a1)) + b1 = max (a2, min (b2, b1)) + if (rvals[1] <= rvals[npts]) { + for (k = 1; (k <= npts) && (rvals[k] < a1); k = k + 1) + ; + for (j = k; (j <= npts) && (rvals[j] <= b1); j = j + 1) + ; + j = j - 1 + } else { + for (k = 1; (k <= npts) && (rvals[k] > b1); k = k + 1) + ; + for (j = k; (j <= npts) && (rvals[j] >= a1); j = j + 1) + ; + j = j - 1 + } + + # Add range + if (k <= j) { + nrgs = RG_NRGS(rg) + if (mod (nrgs, NRGS) == 0) + call realloc (rg, LEN_RG+2*(nrgs+NRGS), TY_STRUCT) + nrgs = nrgs + 1 + RG_NRGS(rg) = nrgs + RG_X1(rg, nrgs) = k + RG_X2(rg, nrgs) = j + RG_NPTS(rg) = RG_NPTS(rg) + + RG_X1(rg, nrgs) - RG_X2(rg, nrgs) + 1 + } + } + } + + call sfree (sp) +end diff --git a/pkg/xtools/rmmed.x b/pkg/xtools/rmmed.x new file mode 100644 index 00000000..940fda9f --- /dev/null +++ b/pkg/xtools/rmmed.x @@ -0,0 +1,446 @@ +include <mach.h> +include <pkg/rmsorted.h> + +# RM_MED -- Running median/maximum/minimum library. +# +# This is a layer over the sorted running routines. +# This layer provides: +# +# 1. Support for multiple datasets (e.g. pixels in running image) +# 2. Support for an interior average +# 3. Support for masks +# 4. Support for excluded index (e.g. image) + + +# Method object structure. +define RM_LEN 26 # Structure size +define RM_RMS Memi[$1] # Pointer to RMEDSRT method +define RM_BOX Memi[$1+1] # Box size +define RM_TYPE Memi[$1+2] # Type of output +define RM_NDATA Memi[$1+3] # Number of datasets +define RM_PIXTYPE Memi[$1+4] # Internal storage type +define RM_GOOD Memi[$1+5] # Ptr to good array (box) +define RM_MASK Memi[$1+6] # Ptr to mask array +define RM_PWIN Memi[$1+7] # Ptr to packed window data (n*box) +define RM_POUT Memi[$1+8] # Ptr to packed outlist data (n*box) +define RM_PMASK Memi[$1+9] # Ptr to mask data (n*(box+15)/16) +define RM_SETMASK P2S($1+10) # Ptr to set mask array (16) +define RM_UNSETMASK P2S($1+18) # Ptr to unset mask array (16) + +define GOOD Memr[RM_GOOD($1)+$2] +define MASK Mems[RM_MASK($1)+$2/16] +define SETMASK Mems[RM_SETMASK($1)+mod($2,16)] +define UNSETMASK Mems[RM_UNSETMASK($1)+mod($2,16)] + +define PWINR Memr[RM_PWIN($1)+RM_BOX($1)*($2-1)] +define PWINS Mems[RM_PWIN($1)+RM_BOX($1)*($2-1)] +define POUT Mems[RM_POUT($1)+(RM_BOX($1)+1)/2*($2-1)] + +define RM_TYPES "|median|maximum|minimum|" +define RM_TYMED 1 # Medain +define RM_TYMAX 2 # Maximum +define RM_TYMIN 3 # Maximum + + +# RM_MED -- Compute next running value. + +real procedure rm_med (rm, nclip, navg, blank, exclude, index, in, mask, nused) + +pointer rm #I RM pointer +real nclip #I Clipping factor +int navg #I Number of central values to average +real blank #I Blank value +int exclude #I Index of excluded data (one indexed) +int index #I Index of new data (one indexed) +real in #I Input data value +short mask #I Input mask value +short nused #O Number of values in calculated result +real val #R Return value + +int i, j, iexclude +short s1, s2, ors(), ands() +pointer rms +real clip, rmsorted() + +begin + # Call sorted running routine. + rms = RM_RMS(rm) + val = rmsorted (rms, nclip, index, in) + + # Set mask if needed. + s2 = mod (index-1, RM_BOX(rm)) + s1 = MASK(rm,s2) + if (mask != 0 || s1 != 0) { + if (mask != 0) + MASK(rm,s2) = ors (s1, SETMASK(rm,s2)) + else + MASK(rm,s2) = ands (s1, UNSETMASK(rm,s2)) + s1 = MASK(rm,s2) + } + + # Recompute value if there are masks or an excluded value. + iexclude = mod (exclude-1, RM_BOX(rm)) + if (s1 == 0 && iexclude < 0) { + do s2 = 0, RM_BOX(rm)-1, 16 { + s1 = MASK(rm,s2) + if (s1 != 0) + break + } + } + if (s1 != 0 || iexclude >= 0) { + nused = 0 + do i = 0, RM_BOX(rm)-1 { + s2 = IN(rms,i) + if (s2 != iexclude) { + s1 = MASK(rm,s2) + if (s1 == 0) { + GOOD(rm,nused) = DATA(rms,i) + nused = nused + 1 + } else if (ands (s1, SETMASK(rm,s2)) == 0) { + GOOD(rm,nused) = DATA(rms,i) + nused = nused + 1 + } + } + } + + if (nused > 2 && nclip > 0.) { + i = nused / 2 + if (mod (nused, 2) == 0) + val = (GOOD(rm,i) + GOOD(rm,i-1)) / 2 + else + val = GOOD(rm,i) + clip = val + nclip * (val - GOOD(rm,0)) + do i = nused, 1, -1 { + if (GOOD(rm,i-1) < clip) + break + } + nused = i + } + + switch (RM_TYPE(rm)) { + case RM_TYMED: + switch (nused) { + case 0: + val = blank + case 1: + val = GOOD(rm,0) + case 2: + val = (GOOD(rm,0) + GOOD(rm,1)) / 2. + default: + for (i = 0; nused-2*i>max(2,navg); i=i+1) + ; + val = GOOD(rm,i) + do j = i+1, nused-i-1 { + val = val + GOOD(rm,j) + } + nused = nused - 2 * i + val = val / nused + } + case RM_TYMAX: + switch (nused) { + case 0: + val = blank + default: + val = GOOD(rm,nused-1) + } + case RM_TYMIN: + switch (nused) { + case 0: + val = blank + default: + val = GOOD(rm,0) + } + } + } else + nused = min (navg, RM_BOX(rm)) + + return (val) +end + + +# RM_GMED -- Running sorted value. + +real procedure rm_gmed (rm, nclip, navg, blank, exclude, nused) + +pointer rm #I RM pointer +real nclip #I Clipping factor +int navg #I Number of central values to average +real blank #I Blank value +int exclude #I Index of excluded data (one indexed) +short nused #O Number of values in calculated result +real val #R Return value + +int i, j, iexclude +short mask, ands() +real clip +pointer rms + +begin + rms = RM_RMS(rm) + iexclude = mod (exclude-1, RM_BOX(rm)) + + # Extract good values to use. + nused = 0 + do i = 0, RM_BOX(rm)-1 { + j = IN(rms,i) + mask = MASK(rm,j) + if (j != iexclude) { + if (mask == 0) { + GOOD(rm,nused) = DATA(rms,i) + nused = nused + 1 + } else if (ands (mask, SETMASK(rm,j)) == 0) { + GOOD(rm,nused) = DATA(rms,i) + nused = nused + 1 + } + } + } + + if (nused > 2 && nclip > 0.) { + i = nused / 2 + if (mod (nused, 2) == 0) + val = (GOOD(rm,i) + GOOD(rm,i-1)) / 2 + else + val = GOOD(rm,i) + clip = val + nclip * (val - GOOD(rm,0)) + do i = nused, 1, -1 { + if (GOOD(rm,i-1) < clip) + break + } + nused = i + } + + switch (RM_TYPE(rm)) { + case RM_TYMED: + switch (nused) { + case 0: + val = blank + case 1: + val = GOOD(rm,0) + case 2: + val = (GOOD(rm,0) + GOOD(rm,1)) / 2. + default: + for (i = 0; nused-2*i>max(2,navg); i=i+1) + ; + val = GOOD(rm,i) + do j = i+1, nused-i-1 { + val = val + GOOD(rm,j) + } + nused = nused - 2 * i + val = val / nused + } + case RM_TYMAX: + switch (nused) { + case 0: + val = blank + default: + val = GOOD(rm,nused-1) + } + case RM_TYMIN: + switch (nused) { + case 0: + val = blank + default: + val = GOOD(rm,0) + } + } + + return (val) +end + + +# RM_GDATA -- Get data value for specified index + +real procedure rm_gdata (rm, index) + +pointer rm #I RM pointer +int index #I Index of new data (one indexed) + +int i, j +pointer rms + +begin + rms = RM_RMS(rm) + i = mod (index-1, RM_BOX(rm)) + do j = 0, RM_BOX(rm)-1 { + if (IN(rms,j) == i) + return (DATA(rms,j)) + } +end + + + +# RM_OPEN -- Open running sorted package. +# +# This is called once to allocate memory and initialize the algorithms. + +pointer procedure rm_open (box, type, ndatasets, pixtype) + +int box #I Median box size (<= 128) +char type[ARB] #I Output type +int ndatasets #I Number of datasets +int pixtype #I Internal storage type +pointer rm #O RM pointer + +char str[8] +int i, j, strdic() +short s, nots(), shifts() +real val +pointer rms, rms_open() + +begin + # Set internal storage type. + if (pixtype == TY_SHORT) + i = TY_SHORT + else + i = TY_REAL + + # Set the output type. + j = strdic (type, str, 8, RM_TYPES) + switch (j) { + case RM_TYMED: + val = 0. + rms = rms_open (box, RMS_TYMED, val) + case RM_TYMAX: + switch (i) { + case TY_SHORT: + val = -MAX_SHORT + rms = rms_open (box, RMS_TYMAX, val) + case TY_REAL: + val = -MAX_REAL + rms = rms_open (box, RMS_TYMAX, val) + } + case RM_TYMIN: + switch (i) { + case TY_SHORT: + val = MAX_SHORT + rms = rms_open (box, RMS_TYMIN, val) + case TY_REAL: + val = MAX_REAL + rms = rms_open (box, RMS_TYMIN, val) + } + default: + call error (1, "Unknown running type") + } + + call calloc (rm, RM_LEN, TY_STRUCT) + call calloc (RM_GOOD(rm), box, TY_REAL) + call calloc (RM_PWIN(rm), box*ndatasets, i) + call calloc (RM_POUT(rm), ndatasets*(box+1)/2, TY_SHORT) + call calloc (RM_PMASK(rm), ndatasets*(box+15)/16, TY_SHORT) + + RM_RMS(rm) = rms + RM_BOX(rm) = box + RM_TYPE(rm) = j + RM_NDATA(rm) = ndatasets + RM_PIXTYPE(rm) = i + RM_MASK(rm) = RM_PMASK(rm) + + # Set mask flags. + s = 1 + do i = 0, 15 { + SETMASK(rm,i) = s + UNSETMASK(rm,i) = nots (s) + s = shifts (s, short(1)) + } + + do i = 1, ndatasets + call rm_pack (rm, i) + + return (rm) +end + + +# RM_CLOSE -- Close running sorted package. + +procedure rm_close (rm) + +pointer rm #I RM pointer + +begin + call rms_close (RM_RMS(rm)) + + call mfree (RM_GOOD(rm), TY_REAL) + call mfree (RM_PWIN(rm), RM_PIXTYPE(rm)) + call mfree (RM_POUT(rm), TY_SHORT) + call mfree (RM_PMASK(rm), TY_SHORT) + call mfree (rm, TY_STRUCT) +end + + +# RM_PACK -- Pack data. + +procedure rm_pack (rm, dataset) + +pointer rm #I RM pointer +int dataset #I Data set + +pointer rms + +begin + rms = RM_RMS(rm) + if (RM_PIXTYPE(rm) == TY_SHORT) + call anirs (DATA(rms,0), PWINS(rm,dataset), RM_BOX(rm)) +# else +# call amovr (DATA(rms,0), PWINR(rm,dataset), RM_BOX(rm)) + call achtsb (OUT(rms,0), POUT(rm,dataset), RM_BOX(rm)) +end + + +# RM_UNPACK -- Unpack data. + +procedure rm_unpack (rm, dataset) + +pointer rm #I RM pointer +int dataset #I Data set + +int i, j, box +pointer rms + +begin + rms = RM_RMS(rm) + box = RM_BOX(rm) + + if (RM_PIXTYPE(rm) == TY_SHORT) + call achtsr (PWINS(rm,dataset), DATA(rms,0), box) + else + RMS_DATA(rms) = RM_PWIN(rm) + box * (dataset - 1) +# call amovr (PWINR(rm,dataset), DATA(rms,0), box) + call achtbs (POUT(rm,dataset), OUT(rms,0), box) + RM_MASK(rm) = RM_PMASK(rm) + (box + 15) / 16 * (dataset - 1) + + do i = 0, box-1 { + j = OUT(rms,i) + IN(rms,j) = i + } +end + + +# ANIRS -- Convert real to short using nearest integer. + +procedure anirs (a, b, n) + +real a[n] #I Input real array +short b[n] #O Output short array +int n #I Number of array values + +int i + +begin + do i = 1, n + b[i] = a[i] + 0.5 +end + + +# RM_DUMP -- Dump data. + +procedure rm_dump (rm, unsorted, sorted, in, out) + +pointer rm #I Method pointer +bool unsorted #I Dump data in unsorted order? +bool sorted #I Dump data in sorted order? +bool in #I Dump in list? +bool out #I Dump out list? + +begin + call rms_dump (RM_RMS(rm), unsorted, sorted, in, out) +end diff --git a/pkg/xtools/rmsorted.x b/pkg/xtools/rmsorted.x new file mode 100644 index 00000000..54d0c2fb --- /dev/null +++ b/pkg/xtools/rmsorted.x @@ -0,0 +1,183 @@ +include <pkg/rmsorted.h> + + +# RMSORTED -- Compute running sorted value. + +real procedure rmsorted (rm, nclip, index, data) + +pointer rm #I Method pointer +real nclip #I Clipping factor +int index #I Index of new data +real data #I Input data value +real val #R Return value + +int i, i1, box, outnext, out, nused +real clip + +begin + # Extract from structure. + box = RMS_BOX(rm) + outnext = mod (index-1, box) + out = OUT(rm,outnext) + + # Find value to replace. + if (out == 0) { + do i = out, box-2 { + i1 = i + 1 + if (data <= DATA(rm,i1)) + break + DATA(rm,i) = DATA(rm,i1) + IN(rm,i) = IN(rm,i1) + OUT(rm,IN(rm,i)) = i + } + } else if (out == box-1) { + do i = out, 1, -1 { + i1 = i - 1 + if (data >= DATA(rm,i1)) + break + DATA(rm,i) = DATA(rm,i1) + IN(rm,i) = IN(rm,i1) + OUT(rm,IN(rm,i)) = i + } + } else if (data > DATA(rm,out+1)) { + do i = out, box-2 { + i1 = i + 1 + if (data <= DATA(rm,i1)) + break + DATA(rm,i) = DATA(rm,i1) + IN(rm,i) = IN(rm,i1) + OUT(rm,IN(rm,i)) = i + } + } else { + do i = out, 1, -1 { + i1 = i - 1 + if (data >= DATA(rm,i1)) + break + DATA(rm,i) = DATA(rm,i1) + IN(rm,i) = IN(rm,i1) + OUT(rm,IN(rm,i)) = i + } + } + + # Set new value. + DATA(rm,i) = data + IN(rm,i) = outnext + OUT(rm,outnext) = i + + # Apply clipping if needed. + nused = box + if (nused > 2 && nclip > 0.) { + i = nused / 2 + if (mod (nused, 2) == 0) + val = (DATA(rm,i) + DATA(rm,i-1)) / 2 + else + val = DATA(rm,i) + clip = val + nclip * (val - DATA(rm,0)) + do i = nused, 1, -1 { + if (DATA(rm,i-1) < clip) + break + } + nused = i + } + + # Compute output value. + switch (RMS_TYPE(rm)) { + case RMS_TYMED: + i = nused / 2 + if (mod (nused, 2) == 0) + val = (DATA(rm,i) + DATA(rm,i-1)) / 2 + else + val = DATA(rm,i) + case RMS_TYMAX: + val = DATA(rm,nused-1) + case RMS_TYMIN: + val = DATA(rm,0) + } + + return (val) +end + + +# RMS_OPEN -- Open running sorted algorithm. + +pointer procedure rms_open (box, type, data) + +int box #I Running box +int type #I Output type +real data #I Initial data value +pointer rm #R Method pointer + +int i + +begin + call malloc (rm, RMS_LEN(box), TY_STRUCT) + RMS_BOX(rm) = box + RMS_TYPE(rm) = type + RMS_DATA(rm) = rm + RMS_OFFSET + RMS_IN(rm) = P2S(RMS_DATA(rm) + box) + RMS_OUT(rm) = RMS_IN(rm) + box + RMS_DATA(rm) = P2R(RMS_DATA(rm)) + + do i = 0, box-1 { + DATA(rm,i) = data + IN(rm,i) = i + OUT(rm,i) = i + } + + return (rm) +end + + +# RMS_CLOSE -- Close running sorted algorithm. + +procedure rms_close (rm) + +pointer rm #I Method pointer + +begin + call mfree (rm, TY_STRUCT) +end + + +# RMS_DUMP -- Dump data structure. + +procedure rms_dump (rm, unsorted, sorted, in, out) + +pointer rm #I RM pointer +bool unsorted #I Dump data in input order? +bool sorted #I Dump data in sorted order? +bool in #I Dump in list? +bool out #I Dump out list? + +int i + +begin + if (unsorted) { + do i = 0, RMS_BOX(rm)-1 { + call printf (" %7.3f") + call pargr (DATA(rm,OUT(rm,i))) + } + call printf ("\n") + } + if (sorted) { + do i = 0, RMS_BOX(rm)-1 { + call printf (" %7.3f") + call pargr (DATA(rm,i)) + } + call printf ("\n") + } + if (in) { + do i = 0, RMS_BOX(rm)-1 { + call printf (" %3d") + call pargs (IN(rm,i)) + } + call printf ("\n") + } + if (out) { + do i = 0, RMS_BOX(rm)-1 { + call printf (" %3d") + call pargs (OUT(rm,i)) + } + call printf ("\n") + } +end diff --git a/pkg/xtools/rmturlach.x b/pkg/xtools/rmturlach.x new file mode 100644 index 00000000..bb23511e --- /dev/null +++ b/pkg/xtools/rmturlach.x @@ -0,0 +1,417 @@ +# Turlach -- Running median library. +# +# The algorithm is that described by Haerdle und Steiger (1995) and the +# implementation is after Turlach. The starting point was the GNU General +# Pubic Licensed code from the R Foundation (see copyright heritage below). +# Besides the language recoding the structure has been significantly changed. +# +# Copyright (C) 1995 Berwin A. Turlach <berwin@alphasun.anu.edu.au> +# Copyright (C) 2000-2 Martin Maechler <maechler@stat.math.ethz.ch> +# Copyright (C) 2003 The R Foundation + +include <mach.h> + +define RMT_OFFSET 4 # Offset to data +define RMT_LEN (RMT_OFFSET+5*$1+3) # Structure length +define RMT_BOX Memi[$1] # Running box size +define RMT_DATA Memi[$1+1] # Sorted data (ptr) +define RMT_IN Memi[$1+2] # Mapping to input (ptr) +define RMT_OUT Memi[$1+3] # Mapping to output (ptr) + +define DATA Memr[RMT_DATA($1)+$2] +define IN Mems[RMT_IN($1)+$2] +define OUT Mems[RMT_OUT($1)+$2] + + +# RMTURLACH -- Compute running median value using the Turlach algorithm. + +real procedure rmturlach (rm, index, data) + +pointer rm #I Method pointer +int index #I Index of new data +real data #I Input data value + +short nrnew, box, outnext, out, leaf, one +data one/1/ + +begin + nrnew = index - 1 + box = RMT_BOX(rm) + outnext = mod (nrnew, box) + out = OUT(rm,outnext) + DATA(rm,out) = data + + leaf = out - box + if (out > box) { + if (data >= DATA(rm,box)) + call rm_uoui (leaf, box, DATA(rm,1), OUT(rm,1), IN(rm,1)) + else + call rm_uodi (leaf, box, nrnew, outnext, data, + DATA(rm,1), OUT(rm,1), IN(rm,1)) + } else if (out < box) { + if (data < DATA(rm,box)) + call rm_dodi (leaf, box, DATA(rm,1), OUT(rm,1), IN(rm,1)) + else + call rm_doui (leaf, box, nrnew, outnext, data, + DATA(rm,1), OUT(rm,1), IN(rm,1)) + } else if (DATA(rm,box) > DATA(rm,box+1)) { + call rm_swap (box, box+one, DATA(rm,1), OUT(rm,1), IN(rm,1)); + call rm_uptoleaf (one, box, DATA(rm,1), OUT(rm,1), IN(rm,1)); + } else if (DATA(rm,box) < DATA(rm,box-1)) { + call rm_swap (box, box-one, DATA(rm,1), OUT(rm,1), IN(rm,1)); + call rm_downtoleaf (-one, box, DATA(rm,1), OUT(rm,1), IN(rm,1)); + } + + return (DATA(rm,box)) +end + + +# RMT_OPEN -- Open Turlach running median algorithm. + +pointer procedure rmt_open (box, data) + +int box #I Running median box +real data #I Initial data value +pointer rm #R Method pointer + +short i, halfbox +#short i, j, k, halfbox, one +#data one/1/ + +begin + call malloc (rm, RMT_LEN(box), TY_STRUCT) + + RMT_BOX(rm) = box + RMT_DATA(rm) = rm + RMT_OFFSET + RMT_IN(rm) = P2S(RMT_DATA(rm) + 2 * box + 1) + RMT_OUT(rm) = RMT_IN(rm) + 2 * box + 1 + + halfbox = (box - 1) / 2 + + do i = 1+halfbox, box+halfbox { + DATA(rm,i) = data + IN(rm,i) = i-halfbox-1 + OUT(rm,i-halfbox-1) = i + } + + do i = 0, halfbox { + DATA(rm,i) = -MAX_REAL + DATA(rm,i+box+halfbox+1) = MAX_REAL + } + + return (rm) +end + + +# RMT_CLOSE -- Close Turlach running median algorithm. + +procedure rmt_close (rm) + +pointer rm #I Method pointer + +begin + call mfree (rm, TY_STRUCT) +end + + +# RMT_DUMP -- Dump data structure. + +procedure rmt_dump (rm, unsorted, sorted, in, out) + +pointer rm #I Method pointer +bool unsorted #I Dump data in unsorted order? +bool sorted #I Dump data in sorted order? +bool in #I Dump in list? +bool out #I Dump out list? + +int i, box, halfbox + +begin + box = RMT_BOX(rm) + halfbox = box / 2 + if (unsorted) { + do i = 1+halfbox, halfbox+box { + call eprintf (" %3.0f") + call pargr (DATA(rm,OUT(rm,i-halfbox-1))) + } + call eprintf ("\n") + } + if (sorted) { + #do i = 0, 2*box { + do i = 1+halfbox, halfbox+box { + call eprintf (" %3.0f") + call pargr (DATA(rm,i)) + } + call eprintf ("\n") + } + if (in) { + #do i = 0, 2*box { + do i = 1+halfbox, halfbox+box { + call eprintf (" %3d") + call pargs (IN(rm,i)) + } + call eprintf ("\n") + } + if (out) { + do i = 0, box-1 { + call eprintf (" %3d") + call pargs (OUT(rm,i)) + } + call eprintf ("\n") + } +end + + +# RM_SWAP -- Swap positions `l' and `r'. + +procedure rm_swap (l, r, window, outlist, nrlist) + +short l #I Index to swap +short r #I Index to swap +real window[ARB] #U Work array +short outlist[ARB] #U Work array +short nrlist[ARB] #U Work array + +short nl, nr +real w + +begin + w = window[l]; window[l] = window[r]; window[r] = w + nl = nrlist[l]; nr = nrlist[r]; nrlist[l] = nr; nrlist[r] = nl + outlist[nl] = r; outlist[nr] = l +end + + +# RM_SIFTUP -- Used only in the initial sorting. + +procedure rm_siftup (l, r, window, outlist, nrlist) + +short l #I Left index +short r #I Right index +real window[ARB] #U Work array +short outlist[ARB] #U Work array +short nrlist[ARB] #U Work array + +short i, j, nrold +real w + +begin + i = l + j = 2 * i + w = window[i] + nrold = nrlist[i] + while (j <= r) { + if (j < r) { + if (window[j] < window[j+1]) + j = j + 1 + } + if (w >= window[j]) + break + + window[i] = window[j] + outlist[nrlist[j]] = i + nrlist[i] = nrlist[j] + i = j + j = 2 * i + } + + window[i] = w + outlist[nrold] = i + nrlist[i] = nrold +end + + +# RM_UOUI - Upper Out Upper In + +procedure rm_uoui (leaf, box, window, outlist, nrlist) + +short leaf #I Leaf +short box #I Box size +real window[ARB] #U Work array +short outlist[ARB] #U Work array +short nrlist[ARB] #U Work array + +short i, j, k + +begin + call rm_uptoleaf (leaf, box, window, outlist, nrlist) + + i = leaf + j = i + box + k = i / 2 + box + while (window[j] < window[k]) { + call rm_swap (j, k, window, outlist, nrlist) + i = (k - box) + j = i + box + k = i / 2 + box + } +end + + +# RM_DODI - Down Out Down In + +procedure rm_dodi (leaf, box, window, outlist, nrlist) + +short leaf #I Leaf +short box #I Box size +real window[ARB] #U Work array +short outlist[ARB] #U Work array +short nrlist[ARB] #U Work array + +short i, j, k + +begin + call rm_downtoleaf (leaf, box, window, outlist, nrlist) + + i = leaf + j = i + box + k = i / 2 + box + while (window[j] > window[k]) { + call rm_swap (j, k, window, outlist, nrlist) + i = (k - box) + j = i + box + k = i / 2 + box + } +end + + +# RM_UODI -- Upper Out Down In + +procedure rm_uodi (leaf, box, nrnew, outnext, in, window, outlist, nrlist) + +short leaf #I Leaf +short box #I Box size +short nrnew #I nrnew +short outnext #I outnext +real in #I Input value +real window[ARB] #U Work array +short outlist[ARB] #U Work array +short nrlist[ARB] #U Work array + +short one +data one/1/ + +begin + call rm_toroot (leaf, box, nrnew, outnext, in, window, outlist, + nrlist) + + if (window[box] < window[box-1]) { + call rm_swap (box, box-one, window, outlist, nrlist) + call rm_downtoleaf (-one, box, window, outlist, nrlist) + } +end + + +# RM_DOUI -- Down Out Upper In + +procedure rm_doui (leaf, box, nrnew, outnext, in, window, outlist, nrlist) + +short leaf #I Leaf +short box #I Box size +short nrnew #I nrnew +short outnext #I outnext +real in #I Input value +real window[ARB] #U Work array +short outlist[ARB] #U Work array +short nrlist[ARB] #U Work array + +short one +data one/1/ + +begin + call rm_toroot (leaf, box, nrnew, outnext, in, window, outlist, + nrlist) + + if (window[box] > window[box+1]) { + call rm_swap (box, box+one, window, outlist, nrlist) + call rm_uptoleaf (one, box, window, outlist, nrlist) + } +end + +# RM_TOROOT + +procedure rm_toroot (leaf, box, nrnew, outnext, in, window, outlist, nrlist) + +short leaf #I Leaf +short box #I Box size +short nrnew #I nrnew +short outnext #I outnext +real in #I Input value +real window[ARB] #U Work array +short outlist[ARB] #U Work array +short nrlist[ARB] #U Work array + +short i, j, k + +begin + i = leaf + repeat { + j = i + box + k = i / 2 + box + window[j] = window[k] + outlist[nrlist[k]] = j + nrlist[j] = nrlist[k] + i = k - box + } until (i == 0) + + window[box] = in + outlist[outnext] = box + nrlist[box] = outnext +end + + +# RM_DOWNTOLEAF + +procedure rm_downtoleaf (leaf, box, window, outlist, nrlist) + +short leaf #I Leaf +short box #I Box size +real window[ARB] #U Work array +short outlist[ARB] #U Work array +short nrlist[ARB] #U Work array + +short i, j, childl, childr + +begin + i = leaf + repeat { + j = i + box + childl = 2 * i + box + childr = childl - 1 + if (window[childl] < window[childr]) + childl = childr + if (window[j] >= window[childl]) + break + call rm_swap (j, childl, window, outlist, nrlist) + i = childl - box + } +end + + +# RM_UPTOLEAF + +procedure rm_uptoleaf (leaf, box, window, outlist, nrlist) + +short leaf #I Leaf +short box #I Box size +real window[ARB] #U Work array +short outlist[ARB] #U Work array +short nrlist[ARB] #U Work array + +short i, j, childl, childr + +begin + i = leaf + repeat { + j = i + box + childl = 2 * i + box + childr = childl + 1 + if (window[childl] > window[childr]) + childl = childr + if (window[j] <= window[childl]) + break + call rm_swap (j, childl, window, outlist, nrlist) + i = childl - box + } +end + diff --git a/pkg/xtools/rngranges.x b/pkg/xtools/rngranges.x new file mode 100644 index 00000000..accfc88d --- /dev/null +++ b/pkg/xtools/rngranges.x @@ -0,0 +1,384 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +include <ctype.h> +include <mach.h> + +# RNGRANGES -- Yet another ranges package. +# This ranges package allows real number ranges (including negative values) +# and @ lists. It is an object oriented package using a pointer. +# +# RNG_OPEN -- Open a range string. Return a pointer to the ranges. +# RNG_CLOSE -- Close range structure. +# RNG_INDEX -- Get ith range element. Return EOF if index is out of range. +# RNG_NEAREST -- Get nearest range index and value to input value. +# Return the difference. +# RNG_INRANGER -- Check if real value is within a range. +# RNG_INRANGEI -- Check if integer value is within a range. +# RNG_ELEMENTR -- Check if real value is an element. +# RNG_ELEMENTI -- Check if integer value is an element. +# RNG_ADD -- Add a range. +# RNG_ERROR -- Set error flag and free memory. + + +# Definitions for the RANGES structure. + +define LEN_RNG 2 # Length of main structure +define RNG_ALLOC 10 # Allocation size +define RNG_MAXINT (MAX_INT/2) # Maximum range integer + +define RNG_NPTS Memi[$1] # Number of points in ranges +define RNG_NRNGS Memi[$1+1] # Number of range intervals +define RNG_X1 Memr[P2R($1+4*($2)-2)] # Start of range +define RNG_X2 Memr[P2R($1+4*($2)-1)] # End of range +define RNG_DX Memr[P2R($1+4*($2))] # Interval step +define RNG_NX Memi[$1+4*($2)+1] # Number of intervals step + + +# RNG_OPEN -- Open a range string. Return a pointer to the ranges. + +pointer procedure rng_open (rstr, r1, r2, dr) + +char rstr[ARB] # Range string +real r1, r2, dr # Default range and range limits +pointer rg # Range pointer + +int i, fd, strlen(), open(), getline() +real a, b, c +pointer sp, str, ptr +errchk open, rng_add + +begin + call smark (sp) + call salloc (str, max (strlen (rstr), SZ_LINE), TY_CHAR) + call calloc (rg, LEN_RNG, TY_STRUCT) + + a = r1 + b = r2 + c = dr + if (IS_INDEF(a)) + a = 0 + if (IS_INDEF(b)) + b = RNG_MAXINT + if (IS_INDEF(c)) + c = 1 + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Add range(s) + if (Memc[str] == '@') { + fd = open (Memc[str+1], READ_ONLY, TEXT_FILE) + while (getline (fd, Memc[str]) != EOF) + call rng_add (rg, Memc[str], a, b, c) + call close (fd) + } else + call rng_add (rg, Memc[str], a, b, c) + } + + if (RNG_NRNGS(rg) == 0) + call rng_add (rg, "*", a, b, c) + + call sfree (sp) + return (rg) +end + + +# RNG_CLOSE -- Close range structure + +procedure rng_close (rg) + +pointer rg #I Range descriptor + +begin + call mfree (rg, TY_STRUCT) +end + + +# RNG_INDEX -- Get ith range element. Return EOF if index is out of range. + +int procedure rng_index (rg, ival, rval) + +pointer rg #I Range descriptor +int ival #I Range index +real rval #O Range value + +int i, j + +begin + if (ival < 1 || ival > RNG_NPTS(rg)) + return (EOF) + + j = 1 + RNG_NPTS(rg) + do i = RNG_NRNGS(rg), 1, -1 { + j = j - RNG_NX(rg,i) + if (ival >= j) { + rval = RNG_X1(rg,i) + (ival - j) * RNG_DX(rg,i) + return (ival) + } + } +end + + +# RNG_NEAREST -- Get nearest range index and value to input value. +# Return the difference. + +real procedure rng_nearest (rg, x, ival, rval) + +pointer rg #I Range descriptor +real x #I Value to be matched +int ival #O Index to range values +real rval #O Range value + +int i, j, k +real drmin, dx + +begin + ival = 1 + rval = RNG_X1(rg,1) + drmin = abs (x - rval) + + k = 1 + do i = 1, RNG_NRNGS(rg) { + dx = x - RNG_X1(rg,i) + j = max (0, min (RNG_NX(rg,i)-1, nint (dx / RNG_DX(rg,i)))) + dx = abs (dx - j * RNG_DX(rg,i)) + if (dx < drmin) { + drmin = dx + ival = j + k + rval = RNG_X1(rg,i) + j * RNG_DX(rg,i) + } + k = k + RNG_NX(rg,i) + } + return (x - rval) +end + + +# RNG_INRANGER -- Check if real value is within a range. + +bool procedure rng_inranger (rg, x) + +pointer rg #I Range descriptor +real x #I Value to check + +int i +real x1, x2 + +begin + do i = 1, RNG_NRNGS(rg) { + x1 = RNG_X1(rg,i) + x2 = RNG_X2(rg,i) + if (x >= min (x1, x2) && x <= max (x1, x2)) + return (true) + } + return (false) +end + + +# RNG_INRANGEI -- Check if integer value is within an integer range. + +bool procedure rng_inrangei (rg, x) + +pointer rg #I Range descriptor +int x #I Value to check + +bool rng_inranger() + +begin + return (rng_inranger (rg, real(x))) +end + + +# RNG_ELEMENTR -- Check if real value is an element. + +bool procedure rng_elementr (rg, x, delta) + +pointer rg #I Range descriptor +real x #I Value to check +real delta #I Maximum distance from element + +int ival +real rval, rng_nearest() + +begin + return (abs (rng_nearest (rg, x, ival, rval)) < delta) +end + + +# RNG_ELEMENTI -- Check if integer value is an element. + +bool procedure rng_elementi (rg, x) + +pointer rg #I Range descriptor +int x #I Value to check + +int ival +real rval, rng_nearest() + +begin + return (abs (rng_nearest (rg, real(x), ival, rval)) < 0.49) +end + + +# RNG_ADD -- Add a range + +procedure rng_add (rg, rstr, r1, r2, dr) + +pointer rg # Range descriptor +char rstr[ARB] # Range string +real r1, r2, dr # Default range and range limits + +int i, j, nrgs, strlen(), ctor() +real x1, x2, dx, nx +pointer sp, str, ptr +errchk rng_error + +begin + call smark (sp) + call salloc (str, strlen (rstr), TY_CHAR) + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + # Convert colon syntax to hyphen/x syntax. + j=0 + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + if (rstr[i] == ':') { + if (j == 0) + Memc[ptr] = '-' + else if (j == 1) + Memc[ptr] = 'x' + else + call rng_error (1, rstr, r1, r2, dr, rg) + j = j + 1 + } else + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Parse range + if (Memc[str] == '@') + call rng_error (2, rstr, r1, r2, dr, rg) + else if (Memc[str] == '*') { + x1 = r1 + x2 = r2 + dx = dr + if ((x2 - x1) / dx + 1 > RNG_MAXINT) + x2 = x1 + (RNG_MAXINT - 1) * dx + } else { + j = 1 + if (ctor (Memc[str], j, x1) == 0) + call rng_error (3, rstr, r1, r2, dr, rg) + if (Memc[str+j-1] == '-') { + j = j + 1 + if (ctor (Memc[str], j, x2) == 0) + call rng_error (3, rstr, r1, r2, dr, rg) + if (Memc[str+j-1] == 'x') { + j = j + 1 + if (ctor (Memc[str], j, dx) == 0) + call rng_error (3, rstr, r1, r2, dr, rg) + } else + dx = dr + } else if (Memc[str+j-1] == 'x') { + j = j + 1 + if (ctor (Memc[str], j, dx) == 0) + call rng_error (3, rstr, r1, r2, dr, rg) + if (dx < 0) + x2 = min (r1, r2) + else + x2 = max (r1, r2) + if ((x2 - x1) / dx + 1 > RNG_MAXINT) + x2 = x1 + (RNG_MAXINT - 1) * dx + } else { + x2 = x1 + dx = dr + } + } + + if (x1 < min (r1, r2) || x1 > max (r1, r2) || + x2 < min (r1, r2) || x2 > max (r1, r2)) + call rng_error (4, rstr, r1, r2, dr, rg) + + nrgs = RNG_NRNGS(rg) + if (mod (nrgs, RNG_ALLOC) == 0) + call realloc (rg, LEN_RNG+4*(nrgs+RNG_ALLOC), TY_STRUCT) + nrgs = nrgs + 1 + RNG_NRNGS(rg) = nrgs + RNG_X1(rg, nrgs) = x1 + RNG_X2(rg, nrgs) = x2 + RNG_DX(rg, nrgs) = dx + nx = (x2 - x1) / dx + 1 + RNG_NX(rg, nrgs) = min (nx, real (RNG_MAXINT)) + RNG_NPTS(rg) = min (nx + RNG_NPTS(rg), real (RNG_MAXINT)) + } + + call sfree (sp) +end + + +# RNG_ERROR -- Set error flag and free memory. +# Note that the pointer is freed at this point. + +procedure rng_error (errnum, rstr, r1, r2, dr, rg) + +int errnum # Error number +char rstr[ARB] # Range string +real r1, r2, dr # Default range and range limits +pointer rg # Range pointer to be freed. + +pointer errstr + +begin + call salloc (errstr, SZ_LINE, TY_CHAR) + + switch (errnum) { + case 1: + call sprintf (Memc[errstr], SZ_LINE, + "Range syntax error: Too many colons (%s)") + call pargstr (rstr) + case 2: + call sprintf (Memc[errstr], SZ_LINE, + "Range syntax error: Cannot nest @files (%s)") + call pargstr (rstr) + case 3: + call sprintf (Memc[errstr], SZ_LINE, + "Range syntax error: (%s)") + call pargstr (rstr) + case 4: + call sprintf (Memc[errstr], SZ_LINE, + "Range syntax error: Range out of bounds %g to %g (%s)") + call pargr (min (r1, r2)) + call pargr (max (r1, r2)) + call pargstr (rstr) + case 5: + call sprintf (Memc[errstr], SZ_LINE, + "Range syntax error: Too many range elements (%s)") + call pargstr (rstr) + } + + call rng_close (rg) + call error (errnum, Memc[errstr]) +end diff --git a/pkg/xtools/rngranges.xBAK b/pkg/xtools/rngranges.xBAK new file mode 100644 index 00000000..3d24e524 --- /dev/null +++ b/pkg/xtools/rngranges.xBAK @@ -0,0 +1,384 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +include <ctype.h> +include <mach.h> + +# RNGRANGES -- Yet another ranges package. +# This ranges package allows real number ranges (including negative values) +# and @ lists. It is an object oriented package using a pointer. +# +# RNG_OPEN -- Open a range string. Return a pointer to the ranges. +# RNG_CLOSE -- Close range structure. +# RNG_INDEX -- Get ith range element. Return EOF if index is out of range. +# RNG_NEAREST -- Get nearest range index and value to input value. +# Return the difference. +# RNG_INRANGER -- Check if real value is within a range. +# RNG_INRANGEI -- Check if integer value is within a range. +# RNG_ELEMENTR -- Check if real value is an element. +# RNG_ELEMENTI -- Check if integer value is an element. +# RNG_ADD -- Add a range. +# RNG_ERROR -- Set error flag and free memory. + + +# Definitions for the RANGES structure. + +define LEN_RNG 2 # Length of main structure +define RNG_ALLOC 10 # Allocation size + +define RNG_NPTS Memi[$1] # Number of points in ranges +define RNG_NRNGS Memi[$1+1] # Number of range intervals +define RNG_X1 Memr[$1+4*($2)-2] # Start of range +define RNG_X2 Memr[$1+4*($2)-1] # End of range +define RNG_DX Memr[$1+4*($2)] # Interval step +define RNG_NX Memi[$1+4*($2)+1] # Number of intervals step + + +# RNG_OPEN -- Open a range string. Return a pointer to the ranges. + +pointer procedure rng_open (rstr, r1, r2, dr) + +char rstr[ARB] # Range string +real r1, r2, dr # Default range and range limits +pointer rg # Range pointer + +int i, fd, strlen(), open(), getline() +real a, b, c +pointer sp, str, ptr +errchk open, rng_add + +begin + call smark (sp) + call salloc (str, max (strlen (rstr), SZ_LINE), TY_CHAR) + call calloc (rg, LEN_RNG, TY_STRUCT) + + a = r1 + b = r2 + c = dr + if (IS_INDEF(a)) + a = 0 + if (IS_INDEF(b)) + b = MAX_INT / 2 + if (IS_INDEF(c)) + c = 1 + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Add range(s) + if (Memc[str] == '@') { + fd = open (Memc[str+1], READ_ONLY, TEXT_FILE) + while (getline (fd, Memc[str]) != EOF) + call rng_add (rg, Memc[str], a, b, c) + call close (fd) + } else + call rng_add (rg, Memc[str], a, b, c) + } + + if (RNG_NRNGS(rg) == 0) + call rng_add (rg, "*", a, b, c) + + call sfree (sp) + return (rg) +end + + +# RNG_CLOSE -- Close range structure + +procedure rng_close (rg) + +pointer rg #I Range descriptor + +begin + call mfree (rg, TY_STRUCT) +end + + +# RNG_INDEX -- Get ith range element. Return EOF if index is out of range. + +int procedure rng_index (rg, ival, rval) + +pointer rg #I Range descriptor +int ival #I Range index +real rval #O Range value + +int i, j + +begin + if (ival < 1 || ival > RNG_NPTS(rg)) + return (EOF) + + j = 1 + RNG_NPTS(rg) + do i = RNG_NRNGS(rg), 1, -1 { + j = j - RNG_NX(rg,i) + if (ival >= j) { + rval = RNG_X1(rg,i) + (ival - j) * RNG_DX(rg,i) + return (ival) + } + } +end + + +# RNG_NEAREST -- Get nearest range index and value to input value. +# Return the difference. + +real procedure rng_nearest (rg, x, ival, rval) + +pointer rg #I Range descriptor +real x #I Value to be matched +int ival #O Index to range values +real rval #O Range value + +int i, j, k +real drmin, dx + +begin + ival = 1 + rval = RNG_X1(rg,1) + drmin = abs (x - rval) + + k = 1 + do i = 1, RNG_NRNGS(rg) { + dx = x - RNG_X1(rg,i) + j = max (0, min (RNG_NX(rg,i)-1, nint (dx / RNG_DX(rg,i)))) + dx = abs (dx - j * RNG_DX(rg,i)) + if (dx < drmin) { + drmin = dx + ival = j + k + rval = RNG_X1(rg,i) + j * RNG_DX(rg,i) + } + k = k + RNG_NX(rg,i) + } + return (x - rval) +end + + +# RNG_INRANGER -- Check if real value is within a range. + +bool procedure rng_inranger (rg, x) + +pointer rg #I Range descriptor +real x #I Value to check + +int i +real x1, x2 + +begin + do i = 1, RNG_NRNGS(rg) { + x1 = RNG_X1(rg,i) + x2 = RNG_X2(rg,i) + if (x >= min (x1, x2) && x <= max (x1, x2)) + return (true) + } + return (false) +end + + +# RNG_INRANGEI -- Check if integer value is within an integer range. + +bool procedure rng_inrangei (rg, x) + +pointer rg #I Range descriptor +int x #I Value to check + +bool rng_inranger() + +begin + return (rng_inranger (rg, real(x))) +end + + +# RNG_ELEMENTR -- Check if real value is an element. + +bool procedure rng_elementr (rg, x, delta) + +pointer rg #I Range descriptor +real x #I Value to check +real delta #I Maximum distance from element + +int ival +real rval, rng_nearest() + +begin + return (abs (rng_nearest (rg, x, ival, rval)) < delta) +end + + +# RNG_ELEMENTI -- Check if integer value is an element. + +bool procedure rng_elementi (rg, x) + +pointer rg #I Range descriptor +int x #I Value to check + +int ival +real rval, rng_nearest() + +begin + return (abs (rng_nearest (rg, real(x), ival, rval)) < 0.49) +end + + +# RNG_ADD -- Add a range. + +procedure rng_add (rg, rstr, r1, r2, dr) + +pointer rg # Range descriptor +char rstr[ARB] # Range string +real r1, r2, dr # Default range and range limits + +int i, j, nx, nrgs, strlen(), ctor() +real x1, x2, dx +pointer sp, str, ptr +errchk rng_error + +begin + call smark (sp) + call salloc (str, strlen (rstr), TY_CHAR) + + i = 1 + while (rstr[i] != EOS) { + + # Find beginning and end of a range and copy it to the work string + while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') + i = i + 1 + if (rstr[i] == EOS) + break + + # Convert colon syntax to hyphen/x syntax. + j=0 + ptr = str + while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || + rstr[i]==EOS)) { + if (rstr[i] == ':') { + if (j == 0) + Memc[ptr] = '-' + else if (j == 1) + Memc[ptr] = 'x' + else + call rng_error (1, rstr, r1, r2, dr, rg) + j = j + 1 + } else + Memc[ptr] = rstr[i] + i = i + 1 + ptr = ptr + 1 + } + Memc[ptr] = EOS + + # Parse range + if (Memc[str] == '@') + call rng_error (2, rstr, r1, r2, dr, rg) + else if (Memc[str] == '*') { + x1 = r1 + x2 = r2 + dx = dr + } else { + j = 1 + if (ctor (Memc[str], j, x1) == 0) + call rng_error (3, rstr, r1, r2, dr, rg) + if (Memc[str+j-1] == '-') { + j = j + 1 + if (ctor (Memc[str], j, x2) == 0) + call rng_error (3, rstr, r1, r2, dr, rg) + if (Memc[str+j-1] == 'x') { + j = j + 1 + if (ctor (Memc[str], j, dx) == 0) + call rng_error (3, rstr, r1, r2, dr, rg) + } else + dx = dr + } else if (Memc[str+j-1] == 'x') { + j = j + 1 + if (ctor (Memc[str], j, dx) == 0) + call rng_error (3, rstr, r1, r2, dr, rg) + if (dx < 0) + x2 = min (r1, r2) + else + x2 = max (r1, r2) + } else { + x2 = x1 + dx = dr + } + } + + if (x1 < min (r1, r2) || x1 > max (r1, r2) || + x2 < min (r1, r2) || x2 > max (r1, r2)) + call rng_error (4, rstr, r1, r2, dr, rg) + + nrgs = RNG_NRNGS(rg) + if (mod (nrgs, RNG_ALLOC) == 0) + call realloc (rg, LEN_RNG+4*(nrgs+RNG_ALLOC), TY_STRUCT) + nrgs = nrgs + 1 + nx = (x2 - x1) / dx + 1 + if (nx > MAX_INT) + call rng_error (5, rstr, r1, r2, dr, rg) + RNG_NRNGS(rg) = nrgs + RNG_X1(rg, nrgs) = x1 + RNG_X2(rg, nrgs) = x2 + RNG_DX(rg, nrgs) = dx + RNG_NX(rg, nrgs) = nx + nx = nx + RNG_NPTS(rg) + if (nx > MAX_INT) + call rng_error (5, rstr, r1, r2, dr, rg) + RNG_NPTS(rg) = nx + } + + call sfree (sp) +end + + +# RNG_ERROR -- Set error flag and free memory. +# Note that the pointer is freed at this point. + +procedure rng_error (errnum, rstr, r1, r2, dr, rg) + +int errnum # Error number +char rstr[ARB] # Range string +real r1, r2, dr # Default range and range limits +pointer rg # Range pointer to be freed. + +pointer errstr + +begin + call salloc (errstr, SZ_LINE, TY_CHAR) + + switch (errnum) { + case 1: + call sprintf (Memc[errstr], SZ_LINE, + "Range syntax error: Too many colons (%s)") + call pargstr (rstr) + case 2: + call sprintf (Memc[errstr], SZ_LINE, + "Range syntax error: Cannot nest @files (%s)") + call pargstr (rstr) + case 3: + call sprintf (Memc[errstr], SZ_LINE, + "Range syntax error: (%s)") + call pargstr (rstr) + case 4: + call sprintf (Memc[errstr], SZ_LINE, + "Range syntax error: Range out of bounds %g to %g (%s)") + call pargr (min (r1, r2)) + call pargr (max (r1, r2)) + call pargstr (rstr) + case 5: + call sprintf (Memc[errstr], SZ_LINE, + "Range syntax error: Too many range elements (%s)") + call pargstr (rstr) + } + + call rng_close (rg) + call error (errnum, Memc[errstr]) +end diff --git a/pkg/xtools/skywcs/doc/README b/pkg/xtools/skywcs/doc/README new file mode 100644 index 00000000..b0998629 --- /dev/null +++ b/pkg/xtools/skywcs/doc/README @@ -0,0 +1,301 @@ + SKYWCS: The Sky Coordinates Package + +1. Introduction + + The skywcs package contains a simple set of routines for managing sky +coordinate information and for transforming from one sky coordinate system to +another. The sky coordinate system is defined either by a system name, e.g. +"J2000", "galactic", etc., or by an image system name, e.g. "dev$ypix" or +"dev$ypix world". + + The skywcs routine are layered on the Starlink Positional Astronomy library +SLALIB which is installed in the IRAF MATH package. Type "help slalib option= +sys" for more information about SLALIB. + + +2. The Interface Routines + +The package prefix is sk. The interface routines are listed below. + + stat = sk_decwcs (ccsystem, mw, coo, imcoo) + stat = sk_decwstr (ccsystem, coo, imcoo) + stat = sk_decim (im, wcs, mw, coo) + sk_enwcs (coo, ccsystem, maxch) + newcoo = sk_copy (coo) + sk_iiprint (label, imagesys, mw, coo) + sk_iiwrite (fd, label, imagesys, mw, coo) +[id]val = sk_stat[id] (coo, param) + sk_stats (coo, param, str, maxch) + sk_set[id] (coo, param, [id]val) + sk_sets (coo, param, str) + sk_ultran (incoo, outcoo, ilng, ilat, olng, olat, npts) + sk_lltran (incoo, outoo, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + sk_equatorial (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, + rv, olng, olat) + sk_saveim (coo, mw, im) + sk_close (coo) + + +3. Notes + + An "include <pkg/skywcs.h>" statement must appear in the calling program +to make the skywcs package parameter definitions visible to the calling +program. + + A "-lxtools -lslalib" must be included in the calling program link line +to link in the skywcs and the slalib routines. + + The sky coordinate descriptor is created with a call to one of the +sk_decwcs, sk_decwstr, or sk_imwcs routines. If the source of the sky +coordinate descriptor is an image then an IRAF MWCS descriptor will be returned +with the sky oordinate descriptor. The sky coordinate descriptor is freed with a +call to sk_close. A separate call to mw_close must be made to free the MWCS +descriptor if one was allocated. + + By default the main skywcs coordinate transformation routine sk_ultran +assumes that the input and output sky coordinates are in hours and degrees +if the input and output coordinate systems are equatorial, otherwise the +coordinates are assumed to be in degrees and degrees. The default input and +output sky coordinate units can be reset with calls to sk_seti. Two lower level +coordinate transformations for handling proper motions sk_lltran and +sk_equatorial are also available. These routines assume that the input and +output coordinates and proper motions are in radians. + + Calling programs working with both sky coordinate and MWCS descriptors +need to be aware that the MWCS routines assume that all sky coordinates +will be input and output in degrees and adjust their code accordingly. + + The skywcs routine sk_saveim can be used to update an image header. + + +3. Examples + +Example 1: Convert from B1950 coordinates to J2000 coordinates. + + include <skywcs.h> + + .... + + # Open input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open output coordinate system. + outstat = sk_decwstr ("J2000", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Do the transformation assuming the input coordinates are in hours + # and degrees. The output coordinates will be in hours and degrees + # as well. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + + +Example 2: Repeat example 1 but convert to galactic coordinates. + + include <skywcs.h> + + .... + + # Open the input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open the output coordinate system. + outstat = sk_decwstr ("galactic", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Dd the transformation assuming the input coordinates are in hours and + # degrees. The output coordinates will be in degrees and degrees. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + +Example 3: Convert a grid of pixel coordinates in the input image to the +equivalent pixel coordinate in the output image using the image world +coordinate systems to connect the two. + + include <skywcs.h> + + .... + + # Mwref will be defined because the input system is an image. + refstat = sk_decwcs ("refimage logical", mwref, refcoo, NULL) + if (refstat == ERR || mwref == NULL) { + if (mwref != NULL) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the reference coordinate descriptor so it expects input in degrees + # and degrees. + call sk_seti (refcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (refcoo, S_NLATUNUTS, SKY_DEGREES) + + # Mwout will be defined because the output system is an image. + outstat = sk_decwcs ("image logical", mwout, outcoo, NULL) + if (outstat == ERR || mwout == NULL) { + if (mwout != NULL) + call mw_close (mwout) + call sk_close (outcoo) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the output coordinate descriptor so it will output coordinates + # in degrees and degrees. + call sk_seti (outcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (outcoo, S_NLATUNUTS, SKY_DEGREES) + + # Compute pixel grid in refimage and store coordinate in the arrays + # xref and yref. + npts = 0 + do j = 1, IM_LEN(im,2), 100 { + do i = 1, IM_LEN(im,1), 100 { + npts = npts + 1 + xref[npts] = i + yref[npts] = j + } + } + + # Convert xref and yref to celestial coordinates raref and decref using + # mwref. The output coordinates will be in degrees and degrees. + ctref = mw_sctran (mwref, "logical", "world", 03B) + do i = 1, npts + call mw_c2trand (ctref, xref[i], yref[i], raref[i], decref[i]) + call ct_free (ctref) + + # Convert the reference celestial coordinates to the output celestial + # coordinate system using the coordinate descriptors. + call sk_ultran (refcoo, outcoo, raref, decref, raout, decout, npts) + + # Convert the output celestial coordinates to pixel coordinates in + # the other image using mwout. + ctout = mw_sctran (mwout, "world", "logical", 03B) + do i = 1, npts + call mw_c2trand (ctout, raout[i], decout[i], xout[i], yout[i]) + call ct_free (ctout) + + # Print the input and output pixel coordinates. + do i = 1, npts { + call printf ("%10.3f %10.3f %10.3f %10.3f\n") + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xout[i]) + call pargd (yout[i]) + } + + # Tidy up. + call mw_close (mwref) + call mw_close (mwout) + call sk_close (refcoo) + call sk_close (outcoo) + + +Example 4: Convert a 2D image with an J2000 tangent plane projection wcs to the +equivalent galactic wcs. The transformation requires a shift in origin and a +rotation. Assume that the ra axis is 1 and the dec axis is 2. The details of +how to compute the rotation are not shown here. See the imcctran task for +details. + + include <mwset.h> + include <skywcs.h> + + ... + + # Open image. + im = immap (image, READ_WRITE, 0) + + # Open the image coordinate system. + instat = sk_decim (im, "logical", mwin, cooin) + if (instat == ERR || mwin == NULL) { + ... + call sk_close (cooin) + ... + } + + # Get the dimensions of the mwcs descriptor. This should be 2. + ndim = mw_ndim (mwin, MW_NPHYSDIM) + + # Get the default coordinates to degrees and degreees. + call sk_seti (cooin, S_NLNGUNITS, SKY_DEGREES) + call sk_seti (cooin, S_NATGUNITS, SKY_DEGREES) + + # Open the output coordinate system. Mwout is NULL because this system + # is not an image. + outstat = sk_decwstr ("galactic", mwout, cooout, cooin) + if (outstat == ERR) { + ... + call sk_close (outstat) + ... + } + + # Make a copy of the mwcs descriptor. + mwout = mw_newcopy (mwin) + + # Allocate space for the r and w vectors and cd matrix. + call malloc (r, ndim, TY_DOUBLE) + call malloc (w, ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (newcd, ndim * ndim, TY_DOUBLE) + + # Assume for simplicty that the MWCS LTERM is the identify transform. + # so we don't have to worry about it. Get the WTERM which consists + # of r the reference point in pixels, w the reference point in degrees, + # and the cd matrix in degrees per pixel. + call mw_gwtermd (mwin, Memd[r], Memd[w], Memd[cd], ndim) + + # Convert the world coordinates zero point. The pixel zero point + # remains the same. + tilng = Memd[w] + tilat = Memd[w+1] + call sk_ultran (incoo, outcoo, tilng, tilat, tolng, tolat, 1) + Memd[w] = tolng + Memd[w+1] = tolat + + # Figure out how much to rotate the coordinate system and edit the + # compute a new CD matrix. Call it newcd. + ... + + # Enter the new CD matrix and zero point. + call mw_swterm (mwout, Memd[r], Memd[w], Memd[newcd], ndim) + + # Update the header. + call sk_saveim (cooout, mwout, im) + call mw_saveim (mwout, im) + ... + + # Tidy up. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (newcd, TY_DOUBLE) + call mw_close (mwin) + call mw_close (mwout) + call sk_close (cooin) + call sk_close (cooout) + call imunmap (im) diff --git a/pkg/xtools/skywcs/doc/ccsystems.hlp b/pkg/xtools/skywcs/doc/ccsystems.hlp new file mode 100644 index 00000000..63a2fde6 --- /dev/null +++ b/pkg/xtools/skywcs/doc/ccsystems.hlp @@ -0,0 +1,134 @@ +.help ccsystems Mar00 Skywcs +.ih +NAME +ccsystems -- list and describe the supported sky coordinate systems +.ih +USAGE +help ccsystems + +.ih +SKY COORDINATE SYSTEMS + +The sky package supports the equatorial ("fk4", "fk4-noe", "fk5", "icrs"), +ecliptic, galactic, and supergalactic celestial coordinate systems. In most +cases and unless otherwise noted users can input their coordinates in +any one of these systems as long as they specify the coordinate system +correctly. + +Considerable flexibility is permitted in how the coordinate systems are +specified, e.g. J2000.0, j2000.0, 2000.0, fk5, fk5 J2000, and fk5 2000.0 +all specify the mean place post-IAU 1976 or FK5 system. Missing equinox and +epoch fields assume reasonable defaults. In most cases the +systems of most interest to users are "icrs", "j2000", and "b1950" +which stand for the ICRS J2000.0, FK5 J2000.0 and FK4 B1950.0 celestial +coordinate systems respectively. The full set of options are listed below: + +.ls equinox [epoch] +The equatorial mean place post-IAU 1976 (FK5) system if equinox is a +Julian epoch, e.g. J2000.0 or 2000.0, or the equatorial mean place +pre-IAU 1976 system (FK4) if equinox is a Besselian epoch, e.g. B1950.0 +or 1950.0. Julian equinoxes are prefixed by a J or j, Besselian equinoxes +by a B or b. Equinoxes without the J / j or B / b prefix are treated as +Besselian epochs if they are < 1984.0, Julian epochs if they are >= 1984.0. +Epoch is the epoch of the observation and may be a Julian +epoch, a Besselian epoch, or a Julian date. Julian epochs +are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to the epoch type of +equinox if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls icrs [equinox] [epoch] +The International Celestial Reference System where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk5 [equinox] [epoch] +The equatorial mean place post-IAU 1976 (FK5) system where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system where equinox is a +Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. Epoch +is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls noefk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system but without the E-terms +where equinox is a Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. If undefined epoch defaults to equinox. +.le +.ls apparent epoch +The equatorial geocentric apparent place post-IAU 1976 system where +epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. +.le +.ls ecliptic epoch +The ecliptic coordinate system where epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch values < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. +.le +.ls galactic [epoch] +The IAU 1958 galactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le +.ls supergalactic [epoch] +The deVaucouleurs supergalactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le + +Fields enclosed in [] are optional with the defaults as described. The epoch +field for the "icrs" , "fk5", "galactic", and "supergalactic" coordinate +systems is only used if the input coordinates are in the equatorial fk4, +noefk4, fk5, or icrs systems and proper motions are used to transform from +coordinate system to another. + +.ih +SEE ALSO +.endhelp diff --git a/pkg/xtools/skywcs/doc/skclose.hlp b/pkg/xtools/skywcs/doc/skclose.hlp new file mode 100644 index 00000000..191b08b5 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skclose.hlp @@ -0,0 +1,23 @@ +.help skclose Mar00 Skywcs +.ih +NAME +skclose -- free the sky coordinate descriptor +.ih +SYNOPSIS +call sk_close (coo) + +.nf +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor to be freed. +.le +.ih +DESCRIPTION +Sk_close frees a previously allocated sky coordinate descriptor. +.ih +SEE ALSO +skdecwcs, skdecwstr, skdecim, skcopy +.endhelp diff --git a/pkg/xtools/skywcs/doc/skcopy.hlp b/pkg/xtools/skywcs/doc/skcopy.hlp new file mode 100644 index 00000000..68219c0d --- /dev/null +++ b/pkg/xtools/skywcs/doc/skcopy.hlp @@ -0,0 +1,24 @@ +.help skcopy Mar00 Skywcs +.ih +NAME +skcopy -- copy a sky coordinate descriptor +.ih +SYNOPSIS +newcoo = sk_copy (coo) + +.nf +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor to be copied. +.le +.ih +DESCRIPTION +Sk_copy is a pointer function which returns a copy of the input sky coordinate +descriptor as its function value. +.ih +SEE ALSO +skdecwcs, skdecwstr, skdecim, skclose +.endhelp diff --git a/pkg/xtools/skywcs/doc/skdecim.hlp b/pkg/xtools/skywcs/doc/skdecim.hlp new file mode 100644 index 00000000..6e570e47 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skdecim.hlp @@ -0,0 +1,56 @@ +.help skdecim Mar00 Skywcs +.ih +NAME +skdecim -- open a sky coordinate descriptor using an image descriptor +.ih +SYNOPSIS +stat = sk_decim (im, mw, coo, imcoo) + +.nf +pointer im # the input image descriptor +pointer mw # the output mwcs descriptor +pointer coo # the output sky coordinate descriptor +pointer imcoo # the input image sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls im +The input image descriptor. +.le +.ls mw +The output mwcs descriptor. A NULL value for mw is returned if the image +world coordinate system cannot be read. +.le +.ls coo +The output sky coordinate descriptor. +.le +.ls imcoo +The parent image sky coordinate descriptor. Imcoo is set to NULL +except in cases where the sky coordinate descriptor for an image is +transformed and written back to the same image. +.le +.ih +DESCRIPTION +Sk_decim is an integer function which returns OK or ERR as its function +value. ERR is returned if a valid sky coordinate system cannot be opened, +OK otherwise. + +Sk_decim returns the image MWCS descriptor mw. The MWCS descriptor is used +to convert from pixel coordinates to world coordinates and vice versa. +The MWCS descriptor must be freed with a call to the MWCS routine +mw_close before task termination. + +Sk_decim returns the sky descriptor coo. The sky coordinate descriptor +is defined even if an error is detected in reading the image celestial +coordinate system, and must be freed with a call to sk_close before +task termination. + +.ih +NOTES +Type "help ccsystems" to see the list of the supported sky coordinate systems. + +Type "help mwcs$MWCS.hlp fi+" to find out more about the IRAF image world +coordinate system library MWCS. +SEE ALSO +skdecwcs, skdecwstr, skcopy, skclose +.endhelp diff --git a/pkg/xtools/skywcs/doc/skdecwcs.hlp b/pkg/xtools/skywcs/doc/skdecwcs.hlp new file mode 100644 index 00000000..2081fd50 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skdecwcs.hlp @@ -0,0 +1,62 @@ +.help skdecwcs Mar00 Skywcs +.ih +NAME +skdecwcs -- open a sky coordinate descriptor using an image or system name +.ih +SYNOPSIS +stat = sk_decwcs (ccsystem, mw, coo, imcoo) + +.nf +char ccsystem # the input celestial coordinate system name +pointer mw # the output mwcs descriptor +pointer coo # the output sky coordinate descriptor +pointer imcoo # the input image sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls ccsystem. +The celestial coordinate system name. Ccsystem is a either an image system +name, e.g. "dev$ypix logical" or "dev$ypix world" or a system name, e.g. +"J2000" or "galactic". +.le +.ls mw +The output mwcs descriptor. A NULL value for mw is returned if the +image world coordinate system cannot be read or ccsystem is not an image +system name. +.le +.ls coo +The output sky coordinate descriptor. +.le +.ls imcoo +The parent image coordinate descriptor. Imcoo is set to NULL +except in cases where the sky coordinate descriptor for an image is +transformed and written back to the same image. +.le +.ih +DESCRIPTION +Sk_decwcs is an integer function which returns OK or ERR as its function +value. ERR is returned if a valid sky coordinate system cannot be opened, +OK otherwise. + +Sk_decwcs returns the image MWCS descriptor mw if ccsystem is an image +system, otherwise it returns NULL. The MWCS descriptor is used +to convert from pixel coordinates to world coordinates and vice versa. +The MWCS descriptor must be freed with a call to the MWCS routine +mw_close before task termination. + +Sk_decwcs returns the sky descriptor coo. The sky coordinate descriptor +is defined even if an error is detected in reading the image celestial +coordinate system, and must be freed with a call to sk_close before +task termination. + +.ih +NOTES +Type "help ccsystems" to see the list of the supported sky coordinate systems. + +Type "help mwcs$MWCS.hlp fi+" to find out more about the IRAF image world +coordinate system library MWCS. + + +SEE ALSO +skdecwstr, skdecim +.endhelp diff --git a/pkg/xtools/skywcs/doc/skdecwstr.hlp b/pkg/xtools/skywcs/doc/skdecwstr.hlp new file mode 100644 index 00000000..0edf7fa0 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skdecwstr.hlp @@ -0,0 +1,46 @@ +.help skdecwstr Mar00 Skywcs +.ih +NAME +skdecwstr -- open a sky coordinate descriptor using a system name +.ih +SYNOPSIS +stat = sk_decwstr (csystem, coo, imcoo) + +.nf +char csystem # the input celestial coordinate system name +pointer coo # the output sky coordinate descriptor +pointer imcoo # the input image sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls csystem +The sky coordinates definition. Ccsystem is a system name, e.g. "J2000" +or "galactic". +.le +.ls coo +The output sky coordinate descriptor. +.le +.ls imcoo +The parent image coordinate descriptor. Imcoo is set to NULL +except in cases where the sky coordinate descriptor for an image is +transformed and written back to the same image. +.le +.ih +DESCRIPTION +Sk_decwstr is an integer function which returns OK or ERR as its function +value. ERR is returned if a valid sky coordinate system cannot be opened, +OK otherwise. + +Sk_decwstr returns the sky descriptor coo. The sky coordinate descriptor +is defined even if an error is detected in reading the image celestial +coordinate system, and must be freed with a call to sk_close before +task termination. + +.ih +NOTES + +Type "help ccsystems" to get a list of the supported sky coordinate systems. + +SEE ALSO +skdecwcs, skdecim, skcopy, skclose +.endhelp diff --git a/pkg/xtools/skywcs/doc/skenwcs.hlp b/pkg/xtools/skywcs/doc/skenwcs.hlp new file mode 100644 index 00000000..cc388108 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skenwcs.hlp @@ -0,0 +1,32 @@ +.help skenwcs Mar00 Skywcs +.ih +NAME +skenwcs -- encode a system name using a sky coordinate descriptor +.ih +SYNOPSIS + +call sk_enwcs (coo, csystem, maxch) + +.nf +pointer coo # the input sky coordinate descriptor +char csystem # the output system name +int maxch # the maximum size of the output system name +.fi +.ih +ARGUMENTS +.ls coo +The input sky coordinate descriptor +.le +.ls csystem +The output system name, e.g. "galactic". +.le +.ls maxch +The maximum size of the output system name. +.le +.ih +DESCRIPTION +Sk_enwcs returns the sky coordinate system name. +.ih +SEE ALSO +skdecwcs, skdecwstr +.endhelp diff --git a/pkg/xtools/skywcs/doc/skequatorial.hlp b/pkg/xtools/skywcs/doc/skequatorial.hlp new file mode 100644 index 00000000..4500b881 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skequatorial.hlp @@ -0,0 +1,58 @@ +.help skequatorial Mar00 Skywcs +.ih +NAME +skequatorial -- apply pm and transform between equatorial coordinate systems +.ih +SYNOPSIS +call sk_equatorial (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + +.nf +pointer incoo # the input sky coordinate descriptor +pointer outcoo # the output sky coordinate descriptor +double ilng, ilat # the input sky coordinates in radians +double ipmlng, ipmlat # the input proper motions in radians / year +double px # the input parallax in arcsec +double rv # the input radial velocity in km / sec (+ve receding) +double olng, olat # the output sky coordinates in radians +.fi +.ih +ARGUMENTS +.ls incoo +The input sky coordinate descriptor. +.le +.ls outcoo +The output sky coordinate descriptor. +.le +.ls ilng, ilat +The input sky coordinates in radians. +.le +.ls ipmlng, ipmlat +The input proper motions. If proper motions are unknown do not set ipmlng +and ipmlat to 0.0, use sk_ultran instead. Note that the ra proper motion +is in dra not cos (dec) * dra units. +.le +.ls px +The parallax in arcseconds. Use 0.0 if the proper motion is unknown unknown. +The parallax value is used only if proper motions are defined. +.le +.ls rv +The radial velocity in km / sec. Use 0.0 if the radial velocity is unknown. +The radial velocity value is used only if proper motions are defined. +.le +.ls olng, olat +The output sky coordinates in radians. +.le +.ih +DESCRIPTION +The coordinates in the input sky coordinate system are converted to +coordinates in the output sky coordinate system. +.ih +NOTES +If the proper motions are undefined use the routine sk_ultran. Zero valued +proper motions are not the same as undefined proper motions. + +.ih +SEE ALSO +sk_lltran, sk_ultran +.endhelp diff --git a/pkg/xtools/skywcs/doc/skiiprint.hlp b/pkg/xtools/skywcs/doc/skiiprint.hlp new file mode 100644 index 00000000..217819c2 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skiiprint.hlp @@ -0,0 +1,39 @@ +.help skiiprint Mar00 Skywcs +.ih +NAME +skiiprint -- print the sky coordinate system summary +.ih +SYNOPSIS + +call sk_iprint (label, imagesys, mw, coo) + +.nf +char label # the input user label +char imagesys # the input image system +pointer mw # the input mwcs descriptor +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls label +The input user supplied label, e.g. "Input System", "Ref System", +"Output System" etc. +.le +.ls imagesys +The input image system, e.g. "dev$ypix logical", "dev$ypix world", etc. +.le +.ls mwcs +The input image mwcs descriptor if defined. If mwcs is defined then +information about which sky coordinate corresponds to which image +axis etc is read from the mwcs descriptor. +.le +.ls coo +The input sky coordinate descriptor. +.le +.ih +DESCRIPTION +A summary of the sky coordinate system is printed on the standard output. +.ih +SEE ALSO +skiiwrite +.endhelp diff --git a/pkg/xtools/skywcs/doc/skiiwrite.hlp b/pkg/xtools/skywcs/doc/skiiwrite.hlp new file mode 100644 index 00000000..c82472f4 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skiiwrite.hlp @@ -0,0 +1,43 @@ +.help skiiwrite Mar00 Skywcs +.ih +NAME +skiiwrite -- write the sky coordinate system summary to a file +.ih +SYNOPSIS + +call sk_iiwrite (outfd, label, imagesys, mw, coo) + +.nf +int outfd # the input file descriptor +char label # the input user label +char imagesys # the input image system +pointer mw # the input mwcs descriptor +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls outfd +The input file descriptor. +.le +.ls label +The input user supplied label, e.g. "Input System", "Ref System", +"Output System" etc. +.le +.ls imagesys +The input image system, e.g. "dev$ypix logical", "dev$ypix world", etc. +.le +.ls mwcs +The input image mwcs descriptor if defined. If mwcs is defined then +information about which sky coordinate corresponds to which image +axis etc is read from the mwcs descriptor. +.le +.ls coo +The input sky coordinate descriptor. +.le +.ih +DESCRIPTION +A summary of the sky coordinate system is written to a file. +.ih +SEE ALSO +skiiprint +.endhelp diff --git a/pkg/xtools/skywcs/doc/sklltran.hlp b/pkg/xtools/skywcs/doc/sklltran.hlp new file mode 100644 index 00000000..b45f3ea4 --- /dev/null +++ b/pkg/xtools/skywcs/doc/sklltran.hlp @@ -0,0 +1,59 @@ +.help sklltran Mar00 Skywcs +.ih +NAME +sklltran -- apply pm and transform between coordinate systems +.ih +SYNOPSIS +call sk_lltran (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, rv, olng, olat) + +.nf +pointer incoo # the input sky coordinate descriptor +pointer outcoo # the output sky coordinate descriptor +double ilng, ilat # the input sky coordinates in radians +double ipmlng, ipmlat # the input proper motions in radians / year +double px # the input parallax in arcsec +double rv # the input radial velocity in km / sec (+ve receding) +double olng, olat # the output sky coordinates in radians +.fi +.ih +ARGUMENTS +.ls incoo +The input sky coordinate descriptor. +.le +.ls outcoo +The output sky coordinate descriptor. +.le +.ls ilng, ilat +The input sky coordinates in radians. +.le +.ls ipmlng, ipmlat +The input proper motions. For these to be applied the input coordinate +system must be an equatorial coordinate system. If proper motions are +unknown do not set ipmlng and ipmlat to 0.0, use sk_ultran instead. Note that +the ra proper motion is in dra not cos (dec) * dra units. +.le +.ls px +The parallax in arcseconds. Use 0.0 if the proper motion is unknown unknown. +The parallax value is used only if proper motions are defined. +.le +.ls rv +The radial velocity in km / sec. Use 0.0 if the radial velocity is unknown. +The radial velocity value is used only if proper motions are defined. +.le +.ls olng, olat +The onput sky coordinates in radians. +.le + +.ih +DESCRIPTION +The coordinates in the input sky coordinate system are converted to +coordinates in the output sky coordinate system. +.ih +NOTES +If the proper motions are undefined use the routine sk_ultran. Zero valued +proper motions are not the same as undefined proper motions. + +.ih +SEE ALSO +sk_ultran, sk_equatorial +.endhelp diff --git a/pkg/xtools/skywcs/doc/sksaveim.hlp b/pkg/xtools/skywcs/doc/sksaveim.hlp new file mode 100644 index 00000000..82c16f3f --- /dev/null +++ b/pkg/xtools/skywcs/doc/sksaveim.hlp @@ -0,0 +1,39 @@ +.help sksaveim Mar00 Skywcs +.ih +NAME +sksaveim -- update the image header using a sky coordinate descriptor +.ih +SYNOPSIS +call sk_saveim (coo, mw, im) + +.nf +pointer coo # the input sky coordinate descriptor +pointer mw # the input mwcs descriptor +pointer im # the input image descriptor +.fi +.ih +ARGUMENTS +.ls coo +The input sky coordinate descriptor. +.le +.ls mw +The IRAF mwcs descriptor. +.le +.ls im +The input image descriptor. +.le +.ih +DESCRIPTION +The image world coordinate system is updated using information in +the sky coordinate descriptor and the mwcs descriptor. + +.ih +NOTES +Note that the sk_saveim call does not include a call to the MWCS mw_saveim +routine. This call must be made separately. + +Type "help mwcs$MWCS.hlp fi+" to find out more about the IRAF image world +coordinate system code. +SEE ALSO +skdecwcs, skdecim +.endhelp diff --git a/pkg/xtools/skywcs/doc/sksetd.hlp b/pkg/xtools/skywcs/doc/sksetd.hlp new file mode 100644 index 00000000..f518d71c --- /dev/null +++ b/pkg/xtools/skywcs/doc/sksetd.hlp @@ -0,0 +1,53 @@ +.help sksetd Mar00 Skywcs +.ih +NAME +sksetd -- set a double sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_setd (coo, parameter, dval) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the double parameter to be set +double dval # the value of the parameter to be set +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be set. The double parameter definitions in skywcs.h are: +.nf + S_VXOFF # the logical ra / longitude offset in pixels + S_VYOFF # the logical dec / latitude offset in pixels + S_VXSTEP # the logical ra / longitude step size in pixels + S_VYSTEP # the logical dec / latitude step size in pixels + S_EQUINOX # the equinox in years + S_EPOCH # the MJD of the observation +.fi +.le +.ls dval +The value of the parameter to be set. +.le +.ih +DESCRIPTION +Sk_setd sets the values of double sky coordinate descriptor parameters. +.ih +NOTES +The offsets and step sizes default to 0 and 1 for both axes. However +if the sky coordinate descriptor was derived from an input image section, e.g. +"dev$ypix[100:300,100:300]" these numbers may assume other values in some +circumstances. + +The equinox and epoch of observation are normally set by the calling program +when the sky coordinate descriptor is initialized, e.g. they default +to 2000.0 and 51544.50000 if the input coordinate system was "fk5". + +In most cases these parameters should not be set by the user. +.ih +SEE ALSO +skseti, sksets +.endhelp diff --git a/pkg/xtools/skywcs/doc/skseti.hlp b/pkg/xtools/skywcs/doc/skseti.hlp new file mode 100644 index 00000000..b08be476 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skseti.hlp @@ -0,0 +1,93 @@ +.help skseti Mar00 Skywcs +.ih +NAME +skseti -- set an integer sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_seti (coo, parameter, ival) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the integer parameter to be set +int ival # the value of the parameter to be set +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be set. The double parameter definitions in skywcs.h are: +.nf + S_CTYPE # the celestial coordinate system type + S_RADECSYS # the equatorial system type + S_NLNGUNITS # the ra / longitude units + S_NLATUNITS # the dec/ latitude units + S_WTYPE # the projection type + S_PLNGAX # the physical ra / longitude axis + S_PLATAX # the physical dec / latitude axis + S_XLAX # the logical ra / longitude axis + S_YLAX # the logical dec / latitude axis + S_PIXTYPE # the IRAF pixel coordinate system type + S_NLNGAX # the length of ra / longitude axis + S_NLATAX # the length of dec / latitude axis + S_STATUS # the coordinate system status +.fi +.le +.ls ival +The value of the parameter to be set. +.le +.ih +DESCRIPTION +Sk_seti sets the values of integer sky coordinate descriptor parameters. +.ih +NOTES +Permitted values of S_CTYPE are CTYPE_EQUATORIAL, CTYPE_ECLIPTIC, +CTYPE_GALACTIC, and CTYPE_SUPERGALACTIC. The corresponding string dictionary +is CTYPE_LIST. + +Permitted types of S_RADECSYS are EQTYPE_FK4, EQTYPE_FK4NOE, +EQTYPE_FK5, EQTYPE, ICRS, and EQTYPE_GAPPT. The corresponding string +dictionary is EQTYPE_LIST. + +Permitted values of S_WTYPE are WTYPE_LIN, WTYPE_AZP, WTYPE_TAN, WTYPE_SIN, +WTYPE_STG, WTYPE_ARC, WTYPE_ZPN, WTYPE_ZEA, WTYPE_AIR, WTYPE_CYP, WTYPE_CAR, +WTYPE_MER, WTYPE_CEA, WTYPE_COP, WTYPE_COD, WTYPE_COE, WTYPE_COO, WTYPE_BON, +WTYPE_PCO, WTYPE_GLS, WTYPE_PAR, WTYPE_AIT, WTYPE_MOL, WTYPE_CSC, WTYPE_QSC, +WTYPE_TSC, WTYPE_TNX, WTYPE_ZPX. The corresponding string dictionary is +WTYPE_LIST. + +Permitted values of S_PIXTYPE are PIXTYPE_LOGICAL, PIXTYPE_TV, +PIXTYPE_PHYSICAL. and PIXTPE_WORLD. The corresponding string dictionary +is PIXTYPE_LIST. + +Permitted values of S_NLNGUNITS are SKY_HOURS, SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LNG_UNITLIST. +Permitted values of S_NLATUNITS are SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LAT_UNITLIST. + +The parameters S_CTYPE, S_RADECSYS, S_NLNGUNITS, and S_NLATUNITS are +important for all sky coordinate descriptors regardless of the source. +The parameters S_WTYPE, S_PLNGAX, S_PLATAX, S_XLAX, S_YLAX, S_PIXTYPE, +S_NLNGAX, and S_NLATAX are only important for sky coordinate descriptors +derived from an image sky coordinate systems. S_STATUS is OK if the sky +coordinate descriptor describes a valid celestial coordinate system, ERR +otherwise. + +In most cases these parameters should not be modified by the user. The +major exceptions are the units parameters S_NLNGUNITS and N_LATUNITS +which assumes default values fo hours and degrees for equatorial sky +coordinate systems and degrees and degrees for other sky coordinate systems. +If the user input and output units are different from the normal defaults +then the units parameters should be set appropriately. + +Parameters that occasionally need to be reset when a coordinate system +is created, edited, or saved to an image are S_WTYPE, S_PIXTYPE, S_PLNGAX, +and S_PLATAX. + +.ih +SEE ALSO +sksetd, sksets +.endhelp diff --git a/pkg/xtools/skywcs/doc/sksets.hlp b/pkg/xtools/skywcs/doc/sksets.hlp new file mode 100644 index 00000000..8e4179b4 --- /dev/null +++ b/pkg/xtools/skywcs/doc/sksets.hlp @@ -0,0 +1,36 @@ +.help sksets Mar00 Skywcs +.ih +NAME +sksets -- set a string sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_sets (coo, parameter, str) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the string parameter to be set +char str # the value of the string parameter to be set +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be set. The string parameter definitions in skywcs.h are: +.nf + S_COOSYSTEM # the celestial coordinate system name +.fi +.le +.ls str +The value of the parameter to be set. +.le +.ih +DESCRIPTION +Sk_sets sets the values of string sky coordinate descriptor parameters. +.ih +SEE ALSO +sksetd, skseti +.endhelp diff --git a/pkg/xtools/skywcs/doc/skstatd.hlp b/pkg/xtools/skywcs/doc/skstatd.hlp new file mode 100644 index 00000000..52dc0c70 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skstatd.hlp @@ -0,0 +1,49 @@ +.help skstatd Mar00 Skywcs +.ih +NAME +skstatd -- get a double sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +dval = sk_statd (coo, parameter) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the double parameter to be returned +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The oarameter to be returned. The double parameter definitions in skywcs.h are: +.nf + S_VXOFF # the logical ra / longitude offset in pixels + S_VYOFF # the logical dec / latitude offset in pixels + S_VXSTEP # the logical ra / longitude step size in pixels + S_VYSTEP # the logical dec / latitude step size in pixels + S_EQUINOX # the equinox in years + S_EPOCH # the MJD of the observation +.fi +.le +.ih +DESCRIPTION +Sk_statd returns the values of double sky coordinate descriptor parameters. + +.ih +NOTES +The offsets and step sizes default to 0 and 1 for both axes. However +if the sky coordinate descriptor was derived from an input image section, e.g. +"dev$ypix[100:300,100:300]" these numbers may assume other values in some +circumstances. + +The equinox and epoch of observation are normally set by the calling program +when the sky coordinate descriptor is initialized, e.g. they default +to 2000.0 and 51544.50000 if the input coordinate system was "fk5". + +.ih +SEE ALSO +skstati, skstats +.endhelp diff --git a/pkg/xtools/skywcs/doc/skstati.hlp b/pkg/xtools/skywcs/doc/skstati.hlp new file mode 100644 index 00000000..90d33eb1 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skstati.hlp @@ -0,0 +1,79 @@ +.help skstati Mar00 Skywcs +.ih +NAME +skstati -- get an integer sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +ival = sk_stati (coo, parameter) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the integer parameter to be returned +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +Parameter to be returned. The integer parameter definitions in skywcs.h are: +.nf + S_CTYPE # the celestial coordinate system type + S_RADECSYS # the equatorial system type + S_NLNGUNITS # the ra / longitude units + S_NLATUNITS # the dec/ latitude units + S_WTYPE # the projection type + S_PLNGAX # the physical ra / longitude axis + S_PLATAX # the physical dec / latitude axis + S_XLAX # the logical ra / longitude axis + S_YLAX # the logical dec / latitude axis + S_PIXTYPE # the IRAF pixel coordinate system type + S_NLNGAX # the length of the ra / longitude axis + S_NLATAX # the length of the dec / latitude axis + S_STATUS # the coordinate system status +.fi +.le +.ih +DESCRIPTION +Sk_stati returns the values of integer sky coordinate descriptor parameters. + +.ih +NOTES +Permitted values of S_CTYPE are CTYPE_EQUATORIAL, CTYPE_ECLIPTIC, +CTYPE_GALACTIC, and CTYPE_SUPERGALACTIC. The corresponding string dictionary +is CTYPE_LIST. + +Permitted types of S_RADECSYS are EQTYPE_FK4, EQTYPE_FK4NOE, +EQTYPE_FK5, EQTYPE, ICRS, and EQTYPE_GAPPT. The corresponding string +dictionary is EQTYPE_LIST. + +Permitted values of S_WTYPE are WTYPE_LIN, WTYPE_AZP, WTYPE_TAN, WTYPE_SIN, +WTYPE_STG, WTYPE_ARC, WTYPE_ZPN, WTYPE_ZEA, WTYPE_AIR, WTYPE_CYP, WTYPE_CAR, +WTYPE_MER, WTYPE_CEA, WTYPE_COP, WTYPE_COD, WTYPE_COE, WTYPE_COO, WTYPE_BON, +WTYPE_PCO, WTYPE_GLS, WTYPE_PAR, WTYPE_AIT, WTYPE_MOL, WTYPE_CSC, WTYPE_QSC, +WTYPE_TSC, WTYPE_TNX, WTYPE_ZPX. The corresponding string dictionary is +WTYPE_LIST. + +Permitted values of S_PIXTYPE are PIXTYPE_LOGICAL, PIXTYPE_TV, +PIXTYPE_PHYSICAL. and PIXTPE_WORLD. The corresponding string dictionary +is PIXTYPE_LIST. + +Permitted values of S_NLNGUNITS are SKY_HOURS, SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LNG_UNITLIST. +Permitted values of S_NLATUNITS are SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LAT_UNITLIST. + +The parameters S_CTYPE, S_RADECSYS, S_NLNGUNITS, and S_NLATUNITS are +important for all sky coordinate descriptors regardless of the source. +The parameters S_WTYPE, S_PLNGAX, S_PLATAX, S_XLAX, S_YLAX, S_PIXTYPE, +S_NLNGAX, and S_NLATAX are only important for sky coordinate descriptors +derived from an image sky coordinate systems. S_STATUS is OK if the sky +coordinate descriptor describes a valid celestial coordinate system, ERR +otherwise. + +.ih +SEE ALSO +skstatd, skstats +.endhelp diff --git a/pkg/xtools/skywcs/doc/skstats.hlp b/pkg/xtools/skywcs/doc/skstats.hlp new file mode 100644 index 00000000..483ed3e5 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skstats.hlp @@ -0,0 +1,40 @@ +.help skstats Mar00 Skywcs +.ih +NAME +skstats -- get a string sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_stats (coo, parameter, str, maxch) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the string parameter to be returned +char str # the returned string parameter value +int maxch # the maximum size of the returned string parameter +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be returned. The string parameter definitions in skywcs.h are: +.nf + S_COOSYSTEM # the celestial coordinate system name +.fi +.le +.ls str +The value of the returned string. +.le +.ls maxch +The maximum size of the returned string. +.le +.ih +DESCRIPTION +Sk_stats returns the values of string sky coordinate descriptor parameters. +.ih +SEE ALSO +skstati, skstatd +.endhelp diff --git a/pkg/xtools/skywcs/doc/skultran.hlp b/pkg/xtools/skywcs/doc/skultran.hlp new file mode 100644 index 00000000..ca02385e --- /dev/null +++ b/pkg/xtools/skywcs/doc/skultran.hlp @@ -0,0 +1,50 @@ +.help skultran Mar00 Skywcs +.ih +NAME +skultran -- transform between coordinate systems +.ih +SYNOPSIS +call sk_ultran (incoo, outcoo, ilng, ilat, olng, olat, npts) + +.nf +pointer incoo # the input sky coordinate descriptor +pointer outcoo # the output sky coordinate descriptor +double ilng, ilat # the input celestial coordinates in expected units +double olng, olat # the output celestial coordinates in expected units +int npts # the number of input and output coordinate pairs +.fi +.ih +ARGUMENTS +.ls incoo +The input sky coordinate descriptor. +.le +.ls outcoo +The output sky coordinate descriptor. +.le +.ls ilng, ilat +The input sky coordinates in the units defined by the integer parameters +S_NLNGUNITS and S_NLATUNITS. +.le +.ls olng, olat +The output sky coordinates in the units defined by the integer parameters +S_NLNGUNITS and S_NLATUNITS. +.le +.ls npts +The number of input and output coordinate pairs. +.le +.ih +DESCRIPTION +The coordinates in the input coordinate system are converted to +coordinates in the output coordinates system. + +If the calling program has not set the S_NLNGUNITS and S_NLATUNITS parameters +in either system the expected coordinates are hours and degrees for +equatorial sky coordinate systems and degrees and degrees for other sky +coordinate systems. The calling program must either perform the necessary +coordinate conversions or set the units parameters in the input and output +sky coordinate descriptors appropriately. + +.ih +SEE ALSO +sk_lltran, sk_equatorial +.endhelp diff --git a/pkg/xtools/skywcs/doc/skywcs.hd b/pkg/xtools/skywcs/doc/skywcs.hd new file mode 100644 index 00000000..74bac140 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skywcs.hd @@ -0,0 +1,25 @@ +# Help directory for the SKYWCS library + +$doc = "./" +$source = "../" + +skdecwcs hlp=doc$skdecwcs.hlp, src=source$skdecode.x +skdecwstr hlp=doc$skdecwstr.hlp, src=source$skdecode.x +skdecim hlp=doc$skdecim.hlp, src=source$skdecode.x +skenwcs hlp=doc$skenwcs.hlp, src=source$skdecode.x +skcopy hlp=doc$skcopy.hlp, src=source$skdecode.x +skiiprint hlp=doc$skiiprint.hlp, src=source$skwrite.x +skiiwrite hlp=doc$skiiwrite.hlp, src=source$skwrite.x +skstati hlp=doc$skstati.hlp, src=source$skstat.x +skstatd hlp=doc$skstatd.hlp, src=source$skstat.x +skstats hlp=doc$skstats.hlp, src=source$skstat.x +skseti hlp=doc$skseti.hlp, src=source$skset.x +sksetd hlp=doc$sksetd.hlp, src=source$skset.x +sksets hlp=doc$sksets.hlp, src=source$skset.x +skultran hlp=doc$skultran.hlp, src=source$skytransform.x +sklltran hlp=doc$sklltran.hlp, src=source$skytransform.x +skequatorial hlp=doc$skequatorial.hlp, src=source$skytransform.x +sksaveim hlp=doc$sksaveim.hlp, src=source$sksaveim.x +skclose hlp=doc$skclose.hlp, src=source$skdecode.x + +ccsystems hlp=doc$ccsystems.hlp diff --git a/pkg/xtools/skywcs/doc/skywcs.hlp b/pkg/xtools/skywcs/doc/skywcs.hlp new file mode 100644 index 00000000..d02f4d2f --- /dev/null +++ b/pkg/xtools/skywcs/doc/skywcs.hlp @@ -0,0 +1,306 @@ +.help skywcs Oct00 xtools +.ih +NAME +skywcs -- sky coordinates package +.ih +SYNOPSIS + +.nf + stat = sk_decwcs (ccsystem, mw, coo, imcoo) + stat = sk_decwstr (ccsystem, coo, imcoo) + stat = sk_decim (im, wcs, mw, coo) + sk_enwcs (coo, ccsystem, maxch) + newcoo = sk_copy (coo) + sk_iiprint (label, imagesys, mw, coo) + sk_iiwrite (fd, label, imagesys, mw, coo) +[id]val = sk_stat[id] (coo, param) + sk_stats (coo, param, str, maxch) + sk_set[id] (coo, param, [id]val) + sk_sets (coo, param, str) + sk_ultran (incoo, outcoo, ilng, ilat, olng, olat, npts) + sk_lltran (incoo, outoo, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + sk_equatorial (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, + rv, olng, olat) + sk_saveim (coo, mw, im) + sk_close (coo) + +.fi +.ih +DESCRIPTION + +The skywcs package contains a simple set of routines for managing +sky coordinate information and for transforming from one sky coordinate +system to another. The sky coordinate system is defined either by a system +name, e.g. "J2000", "galactic", etc. or by an image system name, e.g. +"dev$ypix" or "dev$ypix world". + +The skywcs routine are layered on the Starlink Positional Astronomy library +SLALIB which is installed in the IRAF MATH package. Type "help slalib +option=sys" for more information about SLALIB. + + +.ih +NOTES + +An "include <skywcs.h>" statement must be included in the calling program +to make the skywcs package parameter definitions visible to the calling +program. + +The sky coordinate descriptor is created with a call to one of the sk_decwcs +sk_decwstr or sk_imwcs routines. If the source of sky coordinate descriptor +is an image then an IRAF MWCS descriptor will be returned with the sky +oordinate descriptor. The sky coordinate descriptor is freed with a +call to sk_close. A separate call to mw_close must be made to free the +MWCS descriptor if one was allocated. + +By default the main skywcs coordinate transformation routine sk_ultran +assumes that the input and output sky coordinates are in hours and degrees +if the input and output coordinate systems are equatorial, otherwise the +coordinates are assumed to be in degrees and degrees. The default input and +output sky coordinate units can be reset with calls to sk_seti. Two lower level +coordinate transformations for handling proper motions sk_lltran and +sk_equatorial are also available. These routines expect the input and output +coordinates and proper motions to be in radians. + +Calling programs working with both sky coordinate and MWCS descriptors +need to be aware that the MWCS routines assume that all sky coordinates +must be input in degrees and will be output in degrees and adjust their +code accordingly. + +The skywcs routine sk_saveim can be used to update an image header. + + +.ih +EXAMPLES +.nf +Example 1: Convert from B1950 coordinates to J2000 coordinates. + + include <skywcs.h> + + .... + + # Open input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open output coordinate system. + outstat = sk_decwstr ("J2000", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Do the transformation assuming the input coordinates are in hours + # and degrees. The output coordinates will be in hours and degrees + # as well. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + + +Example 2: Repeat example 1 but convert to galactic coordinates. + + include <skywcs.h> + + .... + + # Open the input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open the output coordinate system. + outstat = sk_decwstr ("galactic", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Do the transformation assuming the input coordinates are in hours and + # degrees. The output coordinates will be in degrees and degrees. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + +Example 3: Convert a grid of pixel coordinates in the input image to the + equivalent pixel coordinate in the output image using the + image world coordinate systems to connect the two. + + include <skywcs.h> + + .... + + # Mwref will be defined because the input system is an image. + refstat = sk_decwcs ("refimage logical", mwref, refcoo, NULL) + if (refstat == ERR || mwref == NULL) { + if (mwref != NULL) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the reference coordinate descriptor so it expects input in degrees + # and degrees. + call sk_seti (refcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (refcoo, S_NLATUNUTS, SKY_DEGREES) + + # Mwout will be defined because the output system is an image. + outstat = sk_decwcs ("image logical", mwout, outcoo, NULL) + if (outstat == ERR || mwout == NULL) { + if (mwout != NULL) + call mw_close (mwout) + call sk_close (outcoo) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the output coordinate descriptor so it will output coordinates + # in degrees and degrees. + call sk_seti (outcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (outcoo, S_NLATUNUTS, SKY_DEGREES) + + # Compute pixel grid in refimage and store coordinate in the arrays + # xref and yref. + npts = 0 + do j = 1, IM_LEN(im,2), 100 { + do i = 1, IM_LEN(im,1), 100 { + npts = npts + 1 + xref[npts] = i + yref[npts] = j + } + } + + # Convert xref and yref to celestial coordinates raref and decref using + # mwref. The output coordinates will be in degrees and degrees. + ctref = mw_sctran (mwref, "logical", "world", 03B) + do i = 1, npts + call mw_c2trand (ctref, xref[i], yref[i], raref[i], decref[i]) + call ct_free (ctref) + + # Convert the reference celestial coordinates to the output celestial + # coordinate system using the coordinate descriptors. + call sk_ultran (refcoo, outcoo, raref, decref, raout, decout, npts) + + # Convert the output celestial coordinates to pixel coordinates in + # the other image using mwout. + ctout = mw_sctran (mwout, "world", "logical", 03B) + do i = 1, npts + call mw_c2trand (ctout, raout[i], decout[i], xout[i], yout[i]) + call ct_free (ctout) + + # Print the input and output pixel coordinates. + do i = 1, npts { + call printf ("%10.3f %10.3f %10.3f %10.3f\n") + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xout[i]) + call pargd (yout[i]) + } + + # Tidy up. + call mw_close (mwref) + call mw_close (mwout) + call sk_close (refcoo) + call sk_close (outcoo) + + +Example 4: Convert a 2D image with an J2000 tangent plane projection + wcs to the equivalent galactic wcs. The transformation + requires a shift in origin and a rotation. Assume that the ra + axis is 1 and the dec axis is 2. The details of how to compute + the rotation are not shown here. See the imcctran task for details. + + include <mwset.h> + include <skywcs.h> + + ... + + # Open image. + im = immap (image, READ_WRITE, 0) + + # Open the image coordinate system. + instat = sk_decim (im, "logical", mwin, cooin) + if (instat == ERR || mwin == NULL) { + ... + call sk_close (cooin) + ... + } + + # Get the dimensions of the mwcs descriptor. This should be 2. + ndim = mw_ndim (mwin, MW_NPHYSDIM) + + # Get the default coordinates to degrees and degreees. + call sk_seti (cooin, S_NLNGUNITS, SKY_DEGREES) + call sk_seti (cooin, S_NATGUNITS, SKY_DEGREES) + + # Open the output coordinate system. Mwout is NULL because this system + # is not an image. + outstat = sk_decwstr ("galactic", mwout, cooout, cooin) + if (outstat == ERR) { + ... + call sk_close (outstat) + ... + } + + # Make a copy of the mwcs descriptor. + mwout = mw_newcopy (mwin) + + # Allocate space for the r and w vectors and cd matrix. + call malloc (r, ndim, TY_DOUBLE) + call malloc (w, ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (newcd, ndim * ndim, TY_DOUBLE) + + # Assume for simplicty that the MWCS LTERM is the identify transform. + # so we don't have to worry about it. Get the WTERM which consists + # of r the reference point in pixels, w the reference point in degrees, + # and the cd matrix in degrees per pixel. + call mw_gwtermd (mwin, Memd[r], Memd[w], Memd[cd], ndim) + + # Convert the world coordinates zero point. The pixel zero point + # remains the same. + tilng = Memd[w] + tilat = Memd[w+1] + call sk_ultran (incoo, outcoo, tilng, tilat, tolng, tolat, 1) + Memd[w] = tolng + Memd[w+1] = tolat + + # Figure out how much to rotate the coordinate system and edit the + # compute a new CD matrix. Call it newcd. + ... + + # Enter the new CD matrix and zero point. + call mw_swterm (mwout, Memd[r], Memd[w], Memd[newcd], ndim) + + # Update the header. + call sk_saveim (cooout, mwout, im) + call mw_saveim (mwout, im) + ... + + # Tidy up. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (newcd, TY_DOUBLE) + call mw_close (mwin) + call mw_close (mwout) + call sk_close (cooin) + call sk_close (cooout) + call imunmap (im) +.fi +.endhelp diff --git a/pkg/xtools/skywcs/doc/skywcs.men b/pkg/xtools/skywcs/doc/skywcs.men new file mode 100644 index 00000000..7502bcd0 --- /dev/null +++ b/pkg/xtools/skywcs/doc/skywcs.men @@ -0,0 +1,15 @@ + skdecwcs - Open a sky coordinate descriptor using an image or system name + skdecwstr - Open a sky coordinate descriptor using a system name + skdecim - Open a sky coordinate descriptor using an image descriptor + skenwcs - Encode a system name using a sky coordinate descriptor + skcopy - Copy a sky coordinate descriptor + skstat[ids] - Get a sky coordinate descriptor parameter value + skset[ids] - Set a sky coordinate descriptor parameter value + skiiprint - Print a sky coordinate descriptor summary + skiiwrite - Write a sky coordinate descriptor summary + skultran - Transform between coordinate systems + sklltran - Apply pm and transform between coordinates systems +skequatorial - Apply pm and transform between equatorial coordinate systems + sksaveim - Update image header using sky coordinate descriptor + skclose - Close the sky coordinate descriptor + ccsystems - Describe the supported celestial coordinate systems diff --git a/pkg/xtools/skywcs/mkpkg b/pkg/xtools/skywcs/mkpkg new file mode 100644 index 00000000..9a46ce5a --- /dev/null +++ b/pkg/xtools/skywcs/mkpkg @@ -0,0 +1,16 @@ +# Libary for the celestial coordinate sytem pacakge + +$checkout libxtools.a lib$ +$update libxtools.a +$checkin libxtools.a lib$ +$exit + +libxtools.a: + skdecode.x <imio.h> <imhdr.h> <mwset.h> "skywcsdef.h" "skywcs.h" + skwrite.x "skywcsdef.h" "skywcs.h" + skstat.x "skywcsdef.h" "skywcs.h" + skset.x "skywcsdef.h" "skywcs.h" + sktransform.x <math.h> "skywcsdef.h" "skywcs.h" + sksaveim.x "skywcsdef.h" "skywcs.h" + skwrdstr.x + ; diff --git a/pkg/xtools/skywcs/skdecode.x b/pkg/xtools/skywcs/skdecode.x new file mode 100644 index 00000000..5fa88f3b --- /dev/null +++ b/pkg/xtools/skywcs/skdecode.x @@ -0,0 +1,999 @@ +include <imio.h> +include <imhdr.h> +include <mwset.h> +include "skywcs.h" +include "skywcsdef.h" + +# SK_DECWCS -- Decode the wcs string which may be either an image name +# plus wcs, e.g. "dev$pix logical" or a string describing the celestial +# coordinate system, e.g. "J2000" or "galactic" into a celestial coordinate +# structure. If the input wcs is an image wcs then a non-NULL pointer to +# the image wcs structure is also returned. ERR is returned if a valid +# celestial coordinate structure cannot be created. + +int procedure sk_decwcs (instr, mw, coo, imcoo) + +char instr[ARB] #I the input wcs string +pointer mw #O the pointer to the image wcs structure +pointer coo #O the pointer to the coordinate structure +pointer imcoo #I pointer to an existing coordinate structure + +int stat +pointer sp, str1, str2, laxno, paxval, im +int sk_strwcs(), sk_decim() +pointer immap() +errchk immap() + +begin + call calloc (coo, LEN_SKYCOOSTRUCT, TY_STRUCT) + call strcpy (instr, SKY_COOSYSTEM(coo), SZ_FNAME) + + # Allocate some working space. + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + call salloc (laxno, IM_MAXDIM, TY_INT) + call salloc (paxval, IM_MAXDIM, TY_INT) + + # Decode the wcs. + call sscan (instr) + call gargwrd (Memc[str1], SZ_LINE) + call gargwrd (Memc[str2], SZ_LINE) + + # First try to open an image wcs. + iferr { + im = immap (Memc[str1], READ_ONLY, 0) + + # Decode the user wcs. + } then { + + # Initialize. + mw = NULL + if (imcoo == NULL) { + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_PLNGAX(coo) = 1 + SKY_PLATAX(coo) = 2 + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_WTYPE(coo) = 0 + } else { + SKY_NLNGAX(coo) = SKY_NLNGAX(imcoo) + SKY_NLATAX(coo) = SKY_NLATAX(imcoo) + SKY_PLNGAX(coo) = SKY_PLNGAX(imcoo) + SKY_PLATAX(coo) = SKY_PLATAX(imcoo) + SKY_XLAX(coo) = SKY_XLAX(imcoo) + SKY_YLAX(coo) = SKY_YLAX(imcoo) + SKY_VXOFF(coo) = SKY_VXOFF(imcoo) + SKY_VYOFF(coo) = SKY_VYOFF(imcoo) + SKY_VXSTEP(coo) = SKY_VXSTEP(imcoo) + SKY_VYSTEP(coo) = SKY_VYSTEP(imcoo) + SKY_WTYPE(coo) = SKY_WTYPE(imcoo) + } + SKY_PIXTYPE(coo) = PIXTYPE_WORLD + + # Decode the actual wcs. + stat = sk_strwcs (instr, SKY_CTYPE(coo), SKY_RADECSYS(coo), + SKY_EQUINOX(coo), SKY_EPOCH(coo)) + switch (SKY_CTYPE(coo)) { + case CTYPE_EQUATORIAL: + SKY_NLNGUNITS(coo) = SKY_HOURS + SKY_NLATUNITS(coo) = SKY_DEGREES + default: + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + } + + # Decode the image wcs. + } else { + stat = sk_decim (im, Memc[str2], mw, coo) + call imunmap (im) + } + + call sfree (sp) + + SKY_STATUS(coo) = stat + return (stat) +end + + +# SK_DECWSTR -- Decode the wcs string coordinate system, e.g. "J2000" or +# "galactic" into a celestial coordinate structure. ERR is returned if a +# valid celestial coordinate structure cannot be created. + +int procedure sk_decwstr (instr, coo, imcoo) + +char instr[ARB] #I the input wcs string +pointer coo #O the pointer to the coordinate structure +pointer imcoo #I pointer to an existing coordinate structure + +int stat +int sk_strwcs() + +begin + call calloc (coo, LEN_SKYCOOSTRUCT, TY_STRUCT) + call strcpy (instr, SKY_COOSYSTEM(coo), SZ_FNAME) + + # Initialize. + if (imcoo == NULL) { + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_PLNGAX(coo) = 1 + SKY_PLATAX(coo) = 2 + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_WTYPE(coo) = 0 + } else { + SKY_NLNGAX(coo) = SKY_NLNGAX(imcoo) + SKY_NLATAX(coo) = SKY_NLATAX(imcoo) + SKY_PLNGAX(coo) = SKY_PLNGAX(imcoo) + SKY_PLATAX(coo) = SKY_PLATAX(imcoo) + SKY_XLAX(coo) = SKY_XLAX(imcoo) + SKY_YLAX(coo) = SKY_YLAX(imcoo) + SKY_VXOFF(coo) = SKY_VXOFF(imcoo) + SKY_VYOFF(coo) = SKY_VYOFF(imcoo) + SKY_VXSTEP(coo) = SKY_VXSTEP(imcoo) + SKY_VYSTEP(coo) = SKY_VYSTEP(imcoo) + SKY_WTYPE(coo) = SKY_WTYPE(imcoo) + } + SKY_PIXTYPE(coo) = PIXTYPE_WORLD + + # Decode the actual wcs. + stat = sk_strwcs (instr, SKY_CTYPE(coo), SKY_RADECSYS(coo), + SKY_EQUINOX(coo), SKY_EPOCH(coo)) + switch (SKY_CTYPE(coo)) { + case CTYPE_EQUATORIAL: + SKY_NLNGUNITS(coo) = SKY_HOURS + SKY_NLATUNITS(coo) = SKY_DEGREES + default: + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + } + + SKY_STATUS(coo) = stat + + return (stat) +end + + +# SK_DECIM -- Given an image descriptor and an image wcs string create a +# celstial coordinate structure. A non-NULL pointer to the image wcs structure +# is also returned. ERR is returned if a valid celestial coordinate descriptor +# cannot be created. + + +int procedure sk_decim (im, wcs, mw, coo) + +pointer im #I the pointer to the input image +char wcs[ARB] #I the wcs string [logical|tv|physical|world] +pointer mw #O the pointer to the image wcs structure +pointer coo #O the pointer to the coordinate structure + +int stat +pointer sp, str1, laxno, paxval +int sk_imwcs(), strdic(), mw_stati() +pointer mw_openim() +errchk mw_openim() + +begin + call malloc (coo, LEN_SKYCOOSTRUCT, TY_STRUCT) + call sprintf (SKY_COOSYSTEM(coo), SZ_FNAME, "%s %s") + call pargstr (IM_HDRFILE(im)) + call pargstr (wcs) + + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (laxno, IM_MAXDIM, TY_INT) + call salloc (paxval, IM_MAXDIM, TY_INT) + + # Try to open the image wcs. + iferr { + mw = mw_openim (im) + + # Set up a dummy wcs. + } then { + + #Initialize. + SKY_CTYPE(coo) = 0 + SKY_RADECSYS(coo) = 0 + SKY_EQUINOX(coo) = INDEFD + SKY_EPOCH(coo) = INDEFD + mw = NULL + SKY_PLNGAX(coo) = 1 + SKY_PLATAX(coo) = 2 + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_WTYPE(coo) = 0 + SKY_PIXTYPE(coo) = PIXTYPE_LOGICAL + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + stat = ERR + + # Decode the wcs. + } else { + SKY_PIXTYPE(coo) = strdic (wcs, Memc[str1], SZ_LINE, PIXTYPE_LIST) + if (SKY_PIXTYPE(coo) <= 0) + SKY_PIXTYPE(coo) = PIXTYPE_LOGICAL + if (sk_imwcs (im, mw, SKY_CTYPE(coo), SKY_PLNGAX(coo), + SKY_PLATAX(coo), SKY_WTYPE(coo), SKY_RADECSYS(coo), + SKY_EQUINOX(coo), SKY_EPOCH(coo)) == OK) { + switch (SKY_CTYPE(coo)) { + case CTYPE_EQUATORIAL: + SKY_NLNGUNITS(coo) = SKY_HOURS + SKY_NLATUNITS(coo) = SKY_DEGREES + default: + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + } + call mw_gaxmap (mw, Memi[laxno], Memi[paxval], mw_stati(mw, + MW_NPHYSDIM)) + if (Memi[laxno+SKY_PLNGAX(coo)-1] < + Memi[laxno+SKY_PLATAX(coo)-1]) { + SKY_XLAX(coo) = Memi[laxno+SKY_PLNGAX(coo)-1] + SKY_YLAX(coo) = Memi[laxno+SKY_PLATAX(coo)-1] + } else { + SKY_XLAX(coo) = Memi[laxno+SKY_PLATAX(coo)-1] + SKY_YLAX(coo) = Memi[laxno+SKY_PLNGAX(coo)-1] + } + if (SKY_XLAX(coo) <= 0 || SKY_YLAX(coo) <= 0) { + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + stat = ERR + } else { + SKY_VXOFF(coo) = IM_VOFF(im,IM_VMAP(im,SKY_XLAX(coo))) + SKY_VYOFF(coo) = IM_VOFF(im,IM_VMAP(im,SKY_YLAX(coo))) + SKY_VXSTEP(coo) = IM_VSTEP(im,SKY_XLAX(coo)) + SKY_VYSTEP(coo) = IM_VSTEP(im,SKY_YLAX(coo)) + SKY_NLNGAX(coo) = IM_LEN(im,SKY_XLAX(coo)) + SKY_NLATAX(coo) = IM_LEN(im,SKY_YLAX(coo)) + stat = OK + } + } else { + call mw_close (mw) + mw = NULL + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + stat = ERR + } + } + + call sfree (sp) + + SKY_STATUS(coo) = stat + return (stat) +end + + +# SK_STRWCS -- Decode the sky coordinate system from an input string. +# The string syntax is [ctype] equinox [epoch]. The various options +# have been placed case statements. Although there is considerable +# duplication of code in the case statements, there are minor differences +# and I found it clearer to write it out rather than trying to be +# concise. I might want to clean this up a bit later. + +int procedure sk_strwcs (instr, ctype, radecsys, equinox, epoch) + +char instr[ARB] #I the input wcs string +int ctype #O the output coordinate type +int radecsys #O the output equatorial reference system +double equinox #O the output equinox +double epoch #O the output epoch of the observation + +int ip, nitems, sctype, sradecsys, stat +pointer sp, str1, str2 +int strdic(), nscan(), ctod() +double sl_ej2d(), sl_epb(), sl_eb2d(), sl_epj() + +begin + # Initialize. + ctype = 0 + radecsys = 0 + equinox = INDEFD + epoch = INDEFD + + # Allocate working space. + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + # Determine the coordinate string. + call sscan (instr) + call gargwrd (Memc[str1], SZ_LINE) + + # Return with an error if the string is blank. + if (Memc[str1] == EOS || nscan() < 1) { + call sfree (sp) + return (ERR) + } else + nitems = 1 + + # If the coordinate type is undefined temporarily default it to + # equatorial. + sctype = strdic (Memc[str1], Memc[str2], SZ_LINE, FTYPE_LIST) + if (sctype <= 0) { + ctype = CTYPE_EQUATORIAL + } else { + switch (sctype) { + case FTYPE_FK4: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_FK4 + case FTYPE_FK4NOE: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_FK4NOE + case FTYPE_FK5: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_FK5 + case FTYPE_ICRS: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_ICRS + case FTYPE_GAPPT: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_GAPPT + case FTYPE_ECLIPTIC: + ctype = CTYPE_ECLIPTIC + case FTYPE_GALACTIC: + ctype = CTYPE_GALACTIC + case FTYPE_SUPERGALACTIC: + ctype = CTYPE_SUPERGALACTIC + } + call gargwrd (Memc[str1], SZ_LINE) + if (nscan() > nitems) + nitems = nitems + 1 + } + sctype = ctype + sradecsys = radecsys + + # Decode the coordinate system. + switch (sctype) { + + # Decode the equatorial system, equinox, and epoch. + case CTYPE_EQUATORIAL: + + switch (sradecsys) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 1950.0d0 + if (Memc[str1] == 'J' || Memc[str1] == 'j') + equinox = sl_epb (sl_ej2d (equinox)) + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_eb2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_eb2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' || + Memc[str2] == 'j')) + epoch = sl_ej2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_eb2d (epoch) + } + + case EQTYPE_FK5, EQTYPE_ICRS: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 2000.0d0 + if (Memc[str1] == 'B' || Memc[str1] == 'b') + equinox = sl_epj(sl_eb2d (equinox)) + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_ej2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_ej2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' || + Memc[str2] == 'b')) + epoch = sl_eb2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_ej2d (epoch) + } + + case EQTYPE_GAPPT: + equinox = 2000.0d0 + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, epoch) <= 0) { + epoch = INDEFD + } else if (epoch <= 3000.0d0) { + if (Memc[str1] == 'B' || Memc[str1] == 'b') + epoch = sl_eb2d (epoch) + else if (Memc[str1] == 'J' || Memc[str1] == 'j') + epoch = sl_ej2d (epoch) + else if (epoch < 1984.0d0) + epoch = sl_eb2d (epoch) + else + epoch = sl_ej2d (epoch) + } else { + epoch = epoch - 2400000.5d0 + } + + default: + ip = 1 + if (Memc[str1] == 'B' || Memc[str1] == 'b') { + radecsys = EQTYPE_FK4 + ip = ip + 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 1950.0d0 + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_eb2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j') + ip = 2 + else if (Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_eb2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' || + Memc[str2] == 'j')) + epoch = sl_ej2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_eb2d (epoch) + } + + } else if (Memc[str1] == 'J' || Memc[str1] == 'j') { + radecsys = EQTYPE_FK5 + ip = ip + 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 2000.0d0 + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_ej2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_ej2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' || + Memc[str2] == 'b')) + epoch = sl_eb2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_ej2d (epoch) + } + + } else if (ctod (Memc[str1], ip, equinox) <= 0) { + ctype = 0 + radecsys = 0 + equinox = INDEFD + epoch = INDEFD + + } else if (equinox < 1984.0d0) { + radecsys = EQTYPE_FK4 + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_eb2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_eb2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' || + Memc[str2] == 'j')) + epoch = sl_ej2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_eb2d (epoch) + } + + } else { + radecsys = EQTYPE_FK5 + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_ej2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_ej2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' || + Memc[str2] == 'b')) + epoch = sl_eb2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_ej2d (epoch) + } + } + } + + # Decode the ecliptic coordinate system. + case CTYPE_ECLIPTIC: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, epoch) <= 0) { + epoch = INDEFD + } else if (epoch <= 3000.0d0) { + if (Memc[str1] == 'B' || Memc[str1] == 'b') + epoch = sl_eb2d (epoch) + else if (Memc[str1] == 'J' || Memc[str1] == 'j') + epoch = sl_ej2d (epoch) + else if (epoch < 1984.0d0) + epoch = sl_eb2d (epoch) + else + epoch = sl_ej2d (epoch) + } else { + epoch = epoch - 2400000.5d0 + } + + # Decode the galactic and supergalactic coordinate system. + case CTYPE_GALACTIC, CTYPE_SUPERGALACTIC: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, epoch) <= 0) { + epoch = sl_eb2d (1950.0d0) + } else if (epoch <= 3000.0d0) { + if (Memc[str1] == 'J' || Memc[str1] == 'j') + epoch = sl_ej2d (epoch) + else if (Memc[str1] == 'B' || Memc[str1] == 'b') + epoch = sl_eb2d (epoch) + else if (epoch < 1984.0d0) + epoch = sl_eb2d (epoch) + else + epoch = sl_ej2d (epoch) + } else { + epoch = epoch - 2400000.5d0 + } + } + + # Return the appropriate error status. + if (ctype == 0) + stat = ERR + else if (ctype == CTYPE_EQUATORIAL && (radecsys == 0 || + IS_INDEFD(equinox) || IS_INDEFD(epoch))) + stat = ERR + else if (ctype == CTYPE_ECLIPTIC && IS_INDEFD(epoch)) + stat = ERR + else + stat = OK + + call sfree (sp) + + return (stat) +end + + +# SK_IMWCS -- Decode the sky coordinate system of the image. Return +# an error if the sky coordinate system is not one of the supported types +# or required information is missing from the image header. + +int procedure sk_imwcs (im, mw, ctype, lngax, latax, wtype, radecsys, + equinox, epoch) + +pointer im #I the image pointer +pointer mw #I pointer to the world coordinate system +int ctype #O the output coordinate type +int lngax #O the output ra/glon/elon axis +int latax #O the output dec/glat/elat axis +int wtype #O the output projection type +int radecsys #O the output equatorial reference system +double equinox #O the output equinox +double epoch #O the output epoch of the observation + +int i, ndim, axtype, day, month, year, ier, oldfits +pointer sp, atval +double hours +double imgetd(), sl_eb2d(), sl_ej2d() +int mw_stati(), strdic(), dtm_decode() +errchk mw_gwattrs(), imgstr(), imgetd() + +begin + call smark (sp) + call salloc (atval, SZ_LINE, TY_CHAR) + + # Initialize + ctype = 0 + lngax = 0 + latax = 0 + wtype = 0 + radecsys = 0 + equinox = INDEFD + epoch = INDEFD + + # Determine the sky coordinate system of the image. + ndim = mw_stati (mw, MW_NPHYSDIM) + do i = 1, ndim { + iferr (call mw_gwattrs (mw, i, "axtype", Memc[atval], SZ_LINE)) + call strcpy ("INDEF", Memc[atval], SZ_LINE) + axtype = strdic (Memc[atval], Memc[atval], SZ_LINE, AXTYPE_LIST) + switch (axtype) { + case AXTYPE_RA, AXTYPE_DEC: + ctype = CTYPE_EQUATORIAL + case AXTYPE_ELON, AXTYPE_ELAT: + ctype = CTYPE_ECLIPTIC + case AXTYPE_GLON, AXTYPE_GLAT: + ctype = CTYPE_GALACTIC + case AXTYPE_SLON, AXTYPE_SLAT: + ctype = CTYPE_SUPERGALACTIC + default: + ; + } + switch (axtype) { + case AXTYPE_RA, AXTYPE_ELON, AXTYPE_GLON, AXTYPE_SLON: + lngax = i + case AXTYPE_DEC, AXTYPE_ELAT, AXTYPE_GLAT, AXTYPE_SLAT: + latax = i + default: + ; + } + } + + # Return if the sky coordinate system cannot be decoded. + if (ctype == 0 || lngax == 0 || latax == 0) { + call sfree (sp) + return (ERR) + } + + # Decode the sky projection. + iferr { + call mw_gwattrs (mw, lngax, "wtype", Memc[atval], SZ_LINE) + } then { + iferr (call mw_gwattrs(mw, latax, "wtype", Memc[atval], SZ_LINE)) + call strcpy ("linear", Memc[atval], SZ_LINE) + } + wtype = strdic (Memc[atval], Memc[atval], SZ_LINE, WTYPE_LIST) + + # Return if the sky projection system is not supported. + if (wtype == 0) { + call sfree (sp) + return (ERR) + } + + # Determine the RA/DEC system and equinox. + if (ctype == CTYPE_EQUATORIAL) { + + # Get the equinox of the coordinate system. The EQUINOX keyword + # takes precedence over EPOCH. + iferr { + equinox = imgetd (im, "EQUINOX") + } then { + iferr { + equinox = imgetd (im, "EPOCH") + } then { + equinox = INDEFD + } + } + + # Determine which equatorial system will be used. The default + # is FK4 if equinox < 1984.0, FK5 if equinox is >= 1984. + iferr { + call imgstr (im, "RADECSYS", Memc[atval], SZ_LINE) + } then { + radecsys = 0 + } else { + call strlwr (Memc[atval]) + radecsys = strdic (Memc[atval], Memc[atval], SZ_LINE, + EQTYPE_LIST) + } + if (radecsys == 0) { + if (IS_INDEFD(equinox)) + radecsys = EQTYPE_FK5 + else if (equinox < 1984.0d0) + radecsys = EQTYPE_FK4 + else + radecsys = EQTYPE_FK5 + } + + # Get the MJD of the observation. If there is no MJD in the + # header use the DATE_OBS keyword value and transform it to + # an MJD. + iferr { + epoch = imgetd (im, "MJD-WCS") + } then { + iferr { + epoch = imgetd (im, "MJD-OBS") + } then { + iferr { + call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE) + } then { + epoch = INDEFD + } else if (dtm_decode (Memc[atval], year, month, day, + hours, oldfits) == OK) { + call sl_cadj (year, month, day, epoch, ier) + if (ier != 0) + epoch = INDEFD + else if (! IS_INDEFD(hours) && hours >= 0.0d0 && + hours <= 24.0d0) + epoch = epoch + hours / 24.0d0 + } else + epoch = INDEFD + } + } + + # Set the default equinox and epoch appropriate for each + # equatorial system if these are undefined. + switch (radecsys) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (IS_INDEFD(equinox)) + equinox = 1950.0d0 + if (IS_INDEFD(epoch)) + epoch = sl_eb2d (1950.0d0) + case EQTYPE_FK5, EQTYPE_ICRS: + if (IS_INDEFD(equinox)) + equinox = 2000.0d0 + if (IS_INDEFD(epoch)) + epoch = sl_ej2d (2000.0d0) + case EQTYPE_GAPPT: + equinox = 2000.0d0 + ; + } + + # Return if the epoch is undefined. This can only occur if + # the equatorial coordinate system is GAPPT and there is NO + # epoch of observation in the image header. + if (IS_INDEFD(epoch)) { + call sfree (sp) + return (ERR) + } + } + + # Get the MJD of the observation. If there is no MJD in the + # header use the DATE_OBS keyword value and transform it to + # an MJD. + if (ctype == CTYPE_ECLIPTIC) { + + iferr { + epoch = imgetd (im, "MJD-WCS") + } then { + iferr { + epoch = imgetd (im, "MJD-OBS") + } then { + iferr { + call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE) + } then { + epoch = INDEFD + } else if (dtm_decode (Memc[atval], year, month, day, + hours, oldfits) == OK) { + call sl_cadj (year, month, day, epoch, ier) + if (ier != 0) + epoch = INDEFD + else if (! IS_INDEFD(hours) && hours >= 0.0d0 && + hours <= 24.0d0) + epoch = epoch + hours / 24.0d0 + } else + epoch = INDEFD + } + } + + # Return if the epoch is undefined. + if (IS_INDEFD(epoch)) { + call sfree (sp) + return (ERR) + } + } + + if (ctype == CTYPE_GALACTIC || ctype == CTYPE_SUPERGALACTIC) { + + # Get the MJD of the observation. If there is no MJD in the + # header use the DATE_OBS keyword value and transform it to + # an MJD. + iferr { + epoch = imgetd (im, "MJD-WCS") + } then { + iferr { + epoch = imgetd (im, "MJD-OBS") + } then { + iferr { + call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE) + } then { + epoch = sl_eb2d (1950.0d0) + } else if (dtm_decode (Memc[atval], year, month, day, + hours, oldfits) == OK) { + call sl_cadj (year, month, day, epoch, ier) + if (ier != 0) + epoch = sl_eb2d (1950.0d0) + else { + if (! IS_INDEFD(hours) && hours >= 0.0d0 && + hours <= 24.0d0) + epoch = epoch + hours / 24.0d0 + #if (epoch < 1984.0d0) + #epoch = sl_eb2d (epoch) + #else + #epoch = sl_ej2d (epoch) + } + } else + epoch = sl_eb2d (1950.0d0) + } + } + } + + call sfree (sp) + + return (OK) +end + + +# SK_ENWCS -- Encode the celestial wcs system. + +procedure sk_enwcs (coo, wcsstr, maxch) + +pointer coo #I the celestial coordinate system descriptor +char wcsstr[ARB] #O the output wcs string +int maxch #I the size of the output string + +double sk_statd(), sl_epj(), sl_epb() +int sk_stati() + +begin + switch (sk_stati (coo, S_CTYPE)) { + + case CTYPE_EQUATORIAL: + + switch (sk_stati(coo, S_RADECSYS)) { + + case EQTYPE_GAPPT: + if (IS_INDEFD(sk_statd(coo, S_EPOCH))) { + call sprintf (wcsstr, maxch, "apparent") + } else { + call sprintf (wcsstr, maxch, "apparent J%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + } + + case EQTYPE_FK5: + call sprintf (wcsstr, maxch, "fk5 J%0.3f J%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + + case EQTYPE_ICRS: + call sprintf (wcsstr, maxch, "icrs J%0.3f J%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + + case EQTYPE_FK4: + call sprintf (wcsstr, maxch, "fk4 B%0.3f B%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epb(sk_statd(coo, S_EPOCH))) + + case EQTYPE_FK4NOE: + call sprintf (wcsstr, maxch, "fk4noe B%0.3f B%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epb(sk_statd(coo, S_EPOCH))) + + default: + wcsstr[1] = EOS + } + + case CTYPE_ECLIPTIC: + if (IS_INDEFD(sk_statd(coo, S_EPOCH))) { + call sprintf (wcsstr, maxch, "ecliptic") + } else { + call sprintf (wcsstr, maxch, "ecliptic J%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + } + + case CTYPE_GALACTIC: + call sprintf (wcsstr, maxch, "galactic J%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + + case CTYPE_SUPERGALACTIC: + call sprintf (wcsstr, maxch, "supergalactic j%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + } +end + + +# SK_COPY -- Copy the coodinate structure. + +pointer procedure sk_copy (cooin) + +pointer cooin #I the pointer to the input structure + +pointer cooout + +begin + if (cooin == NULL) + cooout = NULL + else { + call calloc (cooout, LEN_SKYCOOSTRUCT, TY_STRUCT) + SKY_VXOFF(cooout) = SKY_VXOFF(cooin) + SKY_VYOFF(cooout) = SKY_VYOFF(cooin) + SKY_VXSTEP(cooout) = SKY_VXSTEP(cooin) + SKY_VYSTEP(cooout) = SKY_VYSTEP(cooin) + SKY_EQUINOX(cooout) = SKY_EQUINOX(cooin) + SKY_EPOCH(cooout) = SKY_EPOCH(cooin) + SKY_CTYPE(cooout) = SKY_CTYPE(cooin) + SKY_RADECSYS(cooout) = SKY_RADECSYS(cooin) + SKY_WTYPE(cooout) = SKY_WTYPE(cooin) + SKY_PLNGAX(cooout) = SKY_PLNGAX(cooin) + SKY_PLATAX(cooout) = SKY_PLATAX(cooin) + SKY_XLAX(cooout) = SKY_XLAX(cooin) + SKY_YLAX(cooout) = SKY_YLAX(cooin) + SKY_PIXTYPE(cooout) = SKY_PIXTYPE(cooin) + SKY_NLNGAX(cooout) = SKY_NLNGAX(cooin) + SKY_NLATAX(cooout) = SKY_NLATAX(cooin) + SKY_NLNGUNITS(cooout) = SKY_NLNGUNITS(cooin) + SKY_NLATUNITS(cooout) = SKY_NLATUNITS(cooin) + call strcpy (SKY_COOSYSTEM(cooin), SKY_COOSYSTEM(cooout), + SZ_FNAME) + } + + return (cooout) +end + + +# SK_CLOSE -- Free the coordinate structure. + +procedure sk_close (coo) + +pointer coo #U the input coordinate structure + +begin + if (coo != NULL) + call mfree (coo, TY_STRUCT) +end diff --git a/pkg/xtools/skywcs/sksaveim.x b/pkg/xtools/skywcs/sksaveim.x new file mode 100644 index 00000000..77b5a1d9 --- /dev/null +++ b/pkg/xtools/skywcs/sksaveim.x @@ -0,0 +1,157 @@ +include "skywcsdef.h" +include "skywcs.h" + +# SK_SAVEIM -- Update the image header keywords that describe the +# fundamental coordinate system, CTYPE, RADECSYS, EQUINOX (EPOCH), and +# MJD-WCS. + +procedure sk_saveim (coo, mw, im) + +pointer coo #I pointer to the coordinate structure +pointer mw #I pointer to the mwcs structure +pointer im #I image descriptor + +errchk imdelf() + +begin + # Move all this to a separate routine + switch (SKY_CTYPE(coo)) { + + case CTYPE_EQUATORIAL: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "ra") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "dec") + switch (SKY_RADECSYS(coo)) { + case EQTYPE_FK4: + call imastr (im, "radecsys", "FK4") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + case EQTYPE_FK4NOE: + call imastr (im, "radecsys", "FK4NOE") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + case EQTYPE_FK5: + call imastr (im, "radecsys", "FK5") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + iferr (call imdelf (im, "mjd-wcs")) + ; + case EQTYPE_ICRS: + call imastr (im, "radecsys", "ICRS") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + iferr (call imdelf (im, "mjd-wcs")) + ; + case EQTYPE_GAPPT: + call imastr (im, "radecsys", "GAPPT") + iferr (call imdelf (im, "equinox")) + ; + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + } + + case CTYPE_ECLIPTIC: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "elon") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "elat") + iferr (call imdelf (im, "radecsys")) + ; + iferr (call imdelf (im, "equinox")) + ; + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + + case CTYPE_GALACTIC: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "glon") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "glat") + iferr (call imdelf (im, "radecsys")) + ; + iferr (call imdelf (im, "equinox")) + ; + iferr (call imdelf (im, "mjd-wcs")) + ; + + case CTYPE_SUPERGALACTIC: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "slon") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "slat") + iferr (call imdelf (im, "radecsys")) + ; + iferr (call imdelf (im, "equinox")) + ; + iferr (call imdelf (im, "mjd-wcs")) + ; + } +end + + +# SK_CTYPEIM -- Modify the CTYPE keywords appropriately. This step will +# become unnecessary when MWCS is updated to deal with non-equatorial celestial +# coordinate systems. + +procedure sk_ctypeim (coo, im) + +pointer coo #I pointer to the coordinate structure +pointer im #I image descriptor + +pointer sp, wtype, key1, key2, attr +int sk_wrdstr() + +begin + call smark (sp) + call salloc (key1, 8, TY_CHAR) + call salloc (key2, 8, TY_CHAR) + call salloc (wtype, 3, TY_CHAR) + call salloc (attr, 8, TY_CHAR) + + call sprintf (Memc[key1], 8, "CTYPE%d") + call pargi (SKY_PLNGAX(coo)) + call sprintf (Memc[key2], 8, "CTYPE%d") + call pargi (SKY_PLATAX(coo)) + + if (SKY_WTYPE(coo) <= 0 || SKY_WTYPE(coo) == WTYPE_LIN) { + call imastr (im, Memc[key1], "LINEAR") + call imastr (im, Memc[key2], "LINEAR") + call sfree (sp) + return + } + + if (sk_wrdstr (SKY_WTYPE(coo), Memc[wtype], 3, WTYPE_LIST) <= 0) + call strcpy ("tan", Memc[wtype], 3) + call strupr (Memc[wtype]) + + # Move all this to a separate routine + switch (SKY_CTYPE(coo)) { + + case CTYPE_EQUATORIAL: + call sprintf (Memc[attr], 8, "RA---%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "DEC--%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + case CTYPE_ECLIPTIC: + call sprintf (Memc[attr], 8, "ELON-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "ELAT-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + case CTYPE_GALACTIC: + call sprintf (Memc[attr], 8, "GLON-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "GLAT-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + case CTYPE_SUPERGALACTIC: + call sprintf (Memc[attr], 8, "SLON-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "SLAT-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + default: + call imastr (im, Memc[key1], "LINEAR") + call imastr (im, Memc[key2], "LINEAR") + } + + call sfree (sp) +end diff --git a/pkg/xtools/skywcs/skset.x b/pkg/xtools/skywcs/skset.x new file mode 100644 index 00000000..9e7191c3 --- /dev/null +++ b/pkg/xtools/skywcs/skset.x @@ -0,0 +1,90 @@ +include "skywcsdef.h" +include "skywcs.h" + + +# SK_SETD -- Set a double precision coordinate parameter. + +procedure sk_setd (coo, param, value) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +double value #I the parameter value + +begin + switch (param) { + case S_VXOFF: + SKY_VXOFF(coo) = value + case S_VYOFF: + SKY_VYOFF(coo) = value + case S_VXSTEP: + SKY_VXSTEP(coo) = value + case S_VYSTEP: + SKY_VYSTEP(coo) = value + case S_EQUINOX: + SKY_EQUINOX(coo) = value + case S_EPOCH: + SKY_EPOCH(coo) = value + default: + call error (0, "SKY_SETD: Unknown coordinate system parameter") + } +end + + +# SK_SETI -- Set an integer coordinate parameter. + +procedure sk_seti (coo, param, value) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +int value #I the parameter value + +begin + switch (param) { + case S_CTYPE: + SKY_CTYPE(coo) = value + case S_RADECSYS: + SKY_RADECSYS(coo) = value + case S_WTYPE: + SKY_WTYPE(coo) = value + case S_PLNGAX: + SKY_PLNGAX(coo) = value + case S_PLATAX: + SKY_PLATAX(coo) = value + case S_XLAX: + SKY_XLAX(coo) = value + case S_YLAX: + SKY_YLAX(coo) = value + case S_PIXTYPE: + SKY_PIXTYPE(coo) = value + case S_NLNGAX: + SKY_NLNGAX(coo) = value + case S_NLATAX: + SKY_NLATAX(coo) = value + case S_NLNGUNITS: + SKY_NLNGUNITS(coo) = value + case S_NLATUNITS: + SKY_NLATUNITS(coo) = value + case S_STATUS: + SKY_STATUS(coo) = value + default: + call error (0, "SKY_SETI: Unknown coordinate system parameter") + } +end + + +# SK_SETS -- Set a character string coordinate parameter. + +procedure sk_sets (coo, param, value) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +char value[ARB] #I the parameter value + +begin + switch (param) { + case S_COOSYSTEM: + call strcpy (value, SKY_COOSYSTEM(coo), SZ_FNAME) + default: + call error (0, "SKY_SETSTR: Unknown coordinate system parameter") + } +end diff --git a/pkg/xtools/skywcs/skstat.x b/pkg/xtools/skywcs/skstat.x new file mode 100644 index 00000000..82d2f1c2 --- /dev/null +++ b/pkg/xtools/skywcs/skstat.x @@ -0,0 +1,90 @@ +include "skywcsdef.h" +include "skywcs.h" + + +# SK_STATD -- Get a double precision coordinate parameter. + +double procedure sk_statd (coo, param) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter + +begin + switch (param) { + case S_VXOFF: + return (SKY_VXOFF(coo)) + case S_VYOFF: + return (SKY_VYOFF(coo)) + case S_VXSTEP: + return (SKY_VXSTEP(coo)) + case S_VYSTEP: + return (SKY_VYSTEP(coo)) + case S_EQUINOX: + return (SKY_EQUINOX(coo)) + case S_EPOCH: + return (SKY_EPOCH(coo)) + default: + call error (0, "SKY_STATD: Unknown coordinate system parameter") + } +end + + +# SK_STATI -- Get an integer coordinate parameter. + +int procedure sk_stati (coo, param) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter + +begin + switch (param) { + case S_CTYPE: + return (SKY_CTYPE(coo)) + case S_RADECSYS: + return (SKY_RADECSYS(coo)) + case S_WTYPE: + return (SKY_WTYPE(coo)) + case S_PLNGAX: + return (SKY_PLNGAX(coo)) + case S_PLATAX: + return (SKY_PLATAX(coo)) + case S_XLAX: + return (SKY_XLAX(coo)) + case S_YLAX: + return (SKY_YLAX(coo)) + case S_PIXTYPE: + return (SKY_PIXTYPE(coo)) + case S_NLNGAX: + return (SKY_NLNGAX(coo)) + case S_NLATAX: + return (SKY_NLATAX(coo)) + case S_NLNGUNITS: + return (SKY_NLNGUNITS(coo)) + case S_NLATUNITS: + return (SKY_NLATUNITS(coo)) + case S_STATUS: + return (SKY_STATUS(coo)) + default: + call error (0, "SKY_STATI: Unknown coordinate system parameter") + } +end + + + +# SK_STATS -- Get a character string coordinate parameter. + +procedure sk_stats (coo, param, value, maxch) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +char value #O the output string +int maxch #I the maximum size of the string + +begin + switch (param) { + case S_COOSYSTEM: + call strcpy (SKY_COOSYSTEM(coo), value, maxch) + default: + call error (0, "SKY_GETSTR: Unknown coordinate system parameter") + } +end diff --git a/pkg/xtools/skywcs/sktransform.x b/pkg/xtools/skywcs/sktransform.x new file mode 100644 index 00000000..a8cf87c3 --- /dev/null +++ b/pkg/xtools/skywcs/sktransform.x @@ -0,0 +1,577 @@ +include <math.h> +include "skywcsdef.h" +include "skywcs.h" + +# SK_ULTRAN -- Transform the sky coordinates from the input coordinate +# system to the output coordinate system using the units conversions as +# appropriate. + +procedure sk_ultran (cooin, cooout, ilng, ilat, olng, olat, npts) + +pointer cooin #I pointer to the input coordinate system structure +pointer cooout #I pointer to the output coordinate system structure +double ilng[ARB] #I the input ra/longitude in radians +double ilat[ARB] #I the input dec/latitude in radians +double olng[ARB] #O the output ra/longitude in radians +double olat[ARB] #O the output dec/latitude in radians +int npts #I the number of points to be converted + +double tilng, tilat, tolng, tolat +int i + +begin + do i = 1, npts { + + switch (SKY_NLNGUNITS(cooin)) { + case SKY_HOURS: + tilng = DEGTORAD(15.0d0 * ilng[i]) + case SKY_DEGREES: + tilng = DEGTORAD(ilng[i]) + case SKY_RADIANS: + tilng = ilng[i] + default: + tilng = ilng[i] + } + switch (SKY_NLATUNITS(cooin)) { + case SKY_HOURS: + tilat = DEGTORAD(15.0d0 * ilat[i]) + case SKY_DEGREES: + tilat = DEGTORAD(ilat[i]) + case SKY_RADIANS: + tilat = ilat[i] + default: + tilat = ilat[i] + } + + call sk_lltran (cooin, cooout, tilng, tilat, INDEFD, INDEFD, + 0.0d0, 0.0d0, tolng, tolat) + + switch (SKY_NLNGUNITS(cooout)) { + case SKY_HOURS: + olng[i] = RADTODEG(tolng) / 15.0d0 + case SKY_DEGREES: + olng[i] = RADTODEG(tolng) + case SKY_RADIANS: + olng[i] = tolng + default: + olng[i] = tolng + } + switch (SKY_NLATUNITS(cooout)) { + case SKY_HOURS: + olat[i] = RADTODEG(tolat) / 15.0d0 + case SKY_DEGREES: + olat[i] = RADTODEG(tolat) + case SKY_RADIANS: + olat[i] = tolat + default: + olat[i] = tolat + } + } +end + + +# SK_LLTRAN -- Transform the sky coordinate from the input coordinate +# system to the output coordinate system assuming that all the coordinate +# are in radians. + +procedure sk_lltran (cooin, cooout, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + +pointer cooin #I pointer to the input coordinate system structure +pointer cooout #I pointer to the output coordinate system structure +double ilng #I the input ra/longitude in radians +double ilat #I the input dec/latitude in radians +double ipmlng #I the input proper motion in ra in radians +double ipmlat #I the input proper motion in dec in radians +double px #I the input parallax in arcseconds +double rv #I the input radial velocity in km / second +double olng #O the output ra/longitude in radians +double olat #O the output dec/latitude in radians + +int pmflag +double pmr, pmd +double sl_epj(), sl_epb() + +begin + # Test for the case where the input coordinate system is the + # same as the output coordinate system. + if (SKY_CTYPE(cooin) == SKY_CTYPE(cooout)) { + + switch (SKY_CTYPE(cooin)) { + + case CTYPE_EQUATORIAL: + call sk_equatorial (cooin, cooout, ilng, ilat, ipmlng, + ipmlat, px, rv, olng, olat) + + case CTYPE_ECLIPTIC: + if (SKY_EPOCH(cooin) == SKY_EPOCH(cooout)) { + olng = ilng + olat = ilat + } else { + call sl_eceq (ilng, ilat, SKY_EPOCH(cooin), olng, olat) + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + } + + default: + olng = ilng + olat = ilat + } + + return + } + + # Compute proper motions ? + if (! IS_INDEFD(ipmlng) && ! IS_INDEFD(ipmlat)) + pmflag = YES + else + pmflag = NO + + # Cover the remaining cases. + switch (SKY_CTYPE(cooin)) { + + # The input system is equatorial. + case CTYPE_EQUATORIAL: + + switch (SKY_RADECSYS(cooin)) { + + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epb (SKY_EPOCH(cooin)), sl_epb (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_RADECSYS(cooin) == EQTYPE_FK4) + call sl_suet (olng, olat, SKY_EQUINOX(cooin), olng, olat) + if (SKY_EQUINOX(cooin) != 1950.0d0) + call sl_prcs (1, SKY_EQUINOX(cooin), 1950.0d0, olng, olat) + call sl_adet (olng, olat, 1950.0d0, olng, olat) + if (pmflag == YES) + call sl_f45z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat) + else + call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooin)), + olng, olat) + + case EQTYPE_FK5: + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj(SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + + case EQTYPE_ICRS: + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj(SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, 2000.0d0, olng, olat, pmr, pmd) + + case EQTYPE_GAPPT: + call sl_amp (ilng, ilat, SKY_EPOCH(cooin), 2000.0d0, olng, olat) + + } + + switch (SKY_CTYPE(cooout)) { + + # The output coordinate system is ecliptic. + case CTYPE_ECLIPTIC: + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + + # The output coordinate system is galactic. + case CTYPE_GALACTIC: + call sl_eqga (olng, olat, olng, olat) + + # The output coordinate system is supergalactic. + case CTYPE_SUPERGALACTIC: + call sl_eqga (olng, olat, olng, olat) + call sl_gasu (olng, olat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + # The input coordinate system is ecliptic. + case CTYPE_ECLIPTIC: + + call sl_eceq (ilng, ilat, SKY_EPOCH(cooin), olng, olat) + switch (SKY_CTYPE(cooout)) { + + # The output coordinate system is equatorial. + case CTYPE_EQUATORIAL: + + switch (SKY_RADECSYS(cooout)) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_FK5: + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_ICRS: + #call sl_f5hz (olng, olat, sl_epj(SKY_EPOCH(cooin)), + #olng, olat) + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_GAPPT: + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, + 2000.0d0, SKY_EPOCH(cooout), olng, olat) + } + + # The output coordinate system is galactic. + case CTYPE_GALACTIC: + call sl_eqga (olng, olat, olng, olat) + + # The output system is supergalactic. + case CTYPE_SUPERGALACTIC: + call sl_eqga (olng, olat, olng, olat) + call sl_gasu (olng, olat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + # The input coordinate system is galactic. + case CTYPE_GALACTIC: + + switch (SKY_CTYPE(cooout)) { + + # The output coordinate system is equatorial. + case CTYPE_EQUATORIAL: + call sl_gaeq (ilng, ilat, olng, olat) + + switch (SKY_RADECSYS(cooout)) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_FK5: + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_ICRS: + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_GAPPT: + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, + 2000.0d0, SKY_EPOCH(cooout), olng, olat) + } + + # The output coordinate system is ecliptic. + case CTYPE_ECLIPTIC: + call sl_gaeq (ilng, ilat, olng, olat) + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + + # The output coordinate system is supergalactic. + case CTYPE_SUPERGALACTIC: + call sl_gasu (ilng, ilat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + # The input coordinates are supergalactic. + case CTYPE_SUPERGALACTIC: + + switch (SKY_CTYPE(cooout)) { + + case CTYPE_EQUATORIAL: + call sl_suga (ilng, ilat, olng, olat) + + switch (SKY_RADECSYS(cooout)) { + + case EQTYPE_FK4: + call sl_gaeq (olng, olat, olng, olat) + call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + case EQTYPE_FK4NOE: + call sl_gaeq (olng, olat, olng, olat) + call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_FK5: + call sl_gaeq (olng, olat, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_ICRS: + call sl_gaeq (olng, olat, olng, olat) + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_GAPPT: + call sl_gaeq (olng, olat, olng, olat) + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, + 2000.0d0, SKY_EPOCH(cooout), olng, olat) + } + + case CTYPE_ECLIPTIC: + call sl_suga (ilng, ilat, olng, olat) + call sl_gaeq (olng, olat, olng, olat) + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + + case CTYPE_GALACTIC: + call sl_suga (ilng, ilat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + default: + olng = ilng + olat = ilat + } +end + + +# SK_EQUATORIAL -- Convert / precess equatorial coordinates. + +procedure sk_equatorial (cooin, cooout, ilng, ilat, ipmlng, ipmlat, + px, rv, olng, olat) + +pointer cooin #I the input coordinate system structure +pointer cooout #I the output coordinate system structure +double ilng #I the input ra in radians +double ilat #I the input dec in radians +double ipmlng #I the input proper motion in ra in radians +double ipmlat #I the input proper motion in dec in radians +double px #I the input parallax in arcseconds +double rv #I the input radial valocity in km / second +double olng #O the output ra in radians +double olat #O the output dec in radians + +int pmflag +double pmr, pmd +double sl_epb(), sl_epj() + +begin + # Check to see whether or not conversion / precession is necessary. + if ((SKY_RADECSYS(cooin) == SKY_RADECSYS(cooout)) && + (SKY_EQUINOX(cooin) == SKY_EQUINOX(cooout)) && + (SKY_EPOCH(cooin) == SKY_EPOCH(cooout))) { + olng = ilng + olat = ilat + return + } + + # Compute proper motions ? + if (! IS_INDEFD(ipmlng) && ! IS_INDEFD(ipmlat)) + pmflag = YES + else + pmflag = NO + + switch (SKY_RADECSYS(cooin)) { + + # The input coordinate system is FK4 with or without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epb (SKY_EPOCH(cooin)), sl_epb (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_RADECSYS(cooin) == EQTYPE_FK4) + call sl_suet (olng, olat, SKY_EQUINOX(cooin), olng, olat) + if (SKY_EQUINOX(cooin) != 1950.0d0) + call sl_prcs (1, SKY_EQUINOX(cooin), 1950.0d0, olng, olat) + call sl_adet (olng, olat, 1950.0d0, olng, olat) + if (pmflag == YES) + call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat) + else + call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooin)), + olng, olat) + + switch (SKY_RADECSYS(cooout)) { + + # The output coordinate system is FK4 with and without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is FK5. + case EQTYPE_FK5: + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is ICRS (Hipparcos). + case EQTYPE_ICRS: + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is geocentric apparent. + case EQTYPE_GAPPT: + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0, + SKY_EPOCH(cooout), olng, olat) + } + + # The input coordinate system is FK5 or geocentric apparent. + case EQTYPE_FK5, EQTYPE_GAPPT: + + if (SKY_RADECSYS(cooin) == EQTYPE_FK5) { + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + } else + call sl_amp (ilng, ilat, SKY_EPOCH(cooin), 2000.0d0, olng, olat) + + switch (SKY_RADECSYS(cooout)) { + + # The output coordinate system is FK4 with or without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is FK5. + case EQTYPE_FK5: + if (SKY_EQUINOX(cooin) != SKY_EQUINOX(cooout)) + call sl_prcs (2, SKY_EQUINOX(cooin), SKY_EQUINOX(cooout), + olng, olat) + + # The output coordinate system is ICRS. + case EQTYPE_ICRS: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_f5hz (olng, olat, sl_epj(SKY_EPOCH(cooin)), olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is geocentric apparent. + case EQTYPE_GAPPT: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0, + SKY_EPOCH(cooout), olng, olat) + } + + # The input coordinate system is ICRS. + case EQTYPE_ICRS: + + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + + switch (SKY_RADECSYS(cooout)) { + + # The output coordinate system is FK4 with or without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, 2000.0d0, olng, olat, + pmr, pmd) + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), olng, olat, + pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is FK5. + case EQTYPE_FK5: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, sl_epj(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is ICRS. + case EQTYPE_ICRS: + if (SKY_EQUINOX(cooin) != SKY_EQUINOX(cooout)) + call sl_prcs (2, SKY_EQUINOX(cooin), SKY_EQUINOX(cooout), + olng, olat) + + # The output coordinate system is geocentric apparent. + case EQTYPE_GAPPT: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, sl_epj(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0, + SKY_EPOCH(cooout), olng, olat) + + } + + } +end diff --git a/pkg/xtools/skywcs/skwrdstr.x b/pkg/xtools/skywcs/skwrdstr.x new file mode 100644 index 00000000..a7c6b359 --- /dev/null +++ b/pkg/xtools/skywcs/skwrdstr.x @@ -0,0 +1,53 @@ + +# SK_WRDSTR -- Search a dictionary string for a given string index number. +# This is the opposite function of strdic(), that returns the index for +# given string. The entries in the dictionary string are separated by +# a delimiter character which is the first character of the dictionary +# string. The index of the string found is returned as the function value. +# Otherwise, if there is no string for that index, a zero is returned. + +int procedure sk_wrdstr (index, outstr, maxch, dict) + +int index #I the string index +char outstr[ARB] #O the output string as found in dictionary +int maxch #I the maximum length of output string +char dict[ARB] #I the dictionary string + +int i, len, start, count + +int strlen() + +begin + # Clear output string + outstr[1] = EOS + + # Return if the dictionary is not long enough + if (dict[1] == EOS) + return (0) + + # Initialize counters + count = 1 + len = strlen (dict) + + # Search the dictionary string. This loop only terminates + # successfully if the index is found. Otherwise the procedure + # returns with and error condition. + for (start = 2; count < index; start = start + 1) { + if (dict[start] == dict[1]) + count = count + 1 + if (start == len) + return (0) + } + + # Extract the output string from the dictionary + for (i = start; dict[i] != EOS && dict[i] != dict[1]; i = i + 1) { + if (i - start + 1 > maxch) + break + outstr[i - start + 1] = dict[i] + } + + outstr[i - start + 1] = EOS + + # Return index for output string + return (count) +end diff --git a/pkg/xtools/skywcs/skwrite.x b/pkg/xtools/skywcs/skwrite.x new file mode 100644 index 00000000..2e779b09 --- /dev/null +++ b/pkg/xtools/skywcs/skwrite.x @@ -0,0 +1,510 @@ +include "skywcsdef.h" +include "skywcs.h" + + +# SK_IIPRINT -- Print a summary of the input image or list coordinate system. + +procedure sk_iiprint (label, imagesys, mw, coo) + +char label[ARB] #I the input label +char imagesys[ARB] #I the input image name and wcs +pointer mw #I pointer to the image wcs +pointer coo #I pointer to the coordinate system structure + +begin + if (mw == NULL) + call sk_inprint (label, imagesys, SKY_CTYPE(coo), + SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo)) + else + call sk_imprint (label, imagesys, SKY_CTYPE(coo), SKY_PLNGAX(coo), + SKY_PLATAX(coo), SKY_WTYPE(coo), SKY_PIXTYPE(coo), + SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo)) +end + + +# SK_IIWRITE -- Write a summary of the input image or list coordinate system +# to the output file + +procedure sk_iiwrite (fd, label, imagesys, mw, coo) + +int fd #I the output file descriptor +char label[ARB] #I the input label +char imagesys[ARB] #I the input image name and wcs +pointer mw #I pointer to the image wcs +pointer coo #I pointer to the coordinate system structure + +begin + if (mw == NULL) + call sk_inwrite (fd, label, imagesys, SKY_CTYPE(coo), + SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo)) + else + call sk_imwrite (fd, label, imagesys, SKY_CTYPE(coo), + SKY_PLNGAX(coo), SKY_PLATAX(coo), SKY_WTYPE(coo), + SKY_PIXTYPE(coo), SKY_RADECSYS(coo), SKY_EQUINOX(coo), + SKY_EPOCH(coo)) +end + + +# SK_INPRINT -- Print a summary of the input list coordinate system. +# This should probably be a call to sk_inwrite with the file descriptor +# set to STDOUT to avoid duplication of code. There was a reason for +# having two routines at one point but I can't remember what it was ... + +procedure sk_inprint (label, system, ctype, radecsys, equinox, epoch) + +char label[ARB] #I the input label +char system[ARB] #I the input system +int ctype #I the input coordinate type +int radecsys #I the input equatorial reference system +double equinox #I the input equinox +double epoch #I the input epoch of the observation + +pointer sp, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call printf ("%s: %s Coordinates: equatorial %s\n") + call pargstr (label) + call pargstr (system) + call pargstr (Memc[radecstr]) + switch (radecsys) { + case EQTYPE_GAPPT: + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call printf (" Equinox: J%0.3f Epoch: J%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epj(epoch)) + call pargd (epoch) + default: + call printf (" Equinox: B%0.3f Epoch: B%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epb(epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call printf ("%s: %s Coordinates: ecliptic\n") + call pargstr (label) + call pargstr (system) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call printf ("%s: %s Coordinates: galactic\n") + call pargstr (label) + call pargstr (system) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + + case CTYPE_SUPERGALACTIC: + call printf ("%s: %s Coordinates: supergalactic\n") + call pargstr (label) + call pargstr (system) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + + } + + call sfree (sp) +end + + +# SK_INWRITE -- Write a summary of the input coordinate system. + +procedure sk_inwrite (fd, label, system, ctype, radecsys, equinox, epoch) + +int fd #I the output file descriptor +char label[ARB] #I the input label +char system[ARB] #I the input system +int ctype #I the input coordinate type +int radecsys #I the input equatorial reference system +double equinox #I the input equinox +double epoch #I the input epoch of the observation + +pointer sp, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call fprintf (fd, "# %s: %s Coordinates: equatorial %s\n") + call pargstr (label) + call pargstr (system) + call pargstr (Memc[radecstr]) + switch (radecsys) { + case EQTYPE_GAPPT: + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call fprintf (fd, + "# Equinox: J%0.3f Epoch: J%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epj(epoch)) + call pargd (epoch) + default: + call fprintf (fd, + "# Equinox: B%0.3f Epoch: B%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epb(epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call fprintf (fd, "# %s: %s Coordinates: ecliptic\n") + call pargstr (label) + call pargstr (system) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call fprintf (fd, "# %s: %s Coordinates: galactic\n") + call pargstr (label) + call pargstr (system) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + + case CTYPE_SUPERGALACTIC: + call fprintf (fd, "# %s: %s Coordinates: supergalactic\n") + call pargstr (label) + call pargstr (system) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + + } + + call sfree (sp) +end + + +# SK_IMPRINT -- Print a summary of the input image coordinate system. +# This should probably be a call to sk_imwrite with the file descriptor +# set to STDOUT to avoid duplication of code. There was a reason for +# having two routines at one point but I can't remember what it was ... + +procedure sk_imprint (label, imagesys, ctype, lngax, latax, wtype, ptype, + radecsys, equinox, epoch) + +char label[ARB] #I input label +char imagesys[ARB] #I the input image name and system +int ctype #I the image coordinate type +int lngax #I the image ra/glon/elon axis +int latax #I the image dec/glat/elat axis +int wtype #I the image projection type +int ptype #I the image image wcs type +int radecsys #I the image equatorial reference system +double equinox #I the image equinox +double epoch #I the image epoch of the observation + +pointer sp, imname, projstr, wcsstr, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (wcsstr, SZ_FNAME, TY_CHAR) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + call sscan (imagesys) + call gargwrd (Memc[imname], SZ_FNAME) + if (sk_wrdstr (wtype, Memc[projstr], SZ_FNAME, WTYPE_LIST) <= 0) + call strcpy ("linear", Memc[projstr], SZ_FNAME) + call strupr (Memc[projstr]) + if (sk_wrdstr (ptype, Memc[wcsstr], SZ_FNAME, PIXTYPE_LIST) <= 0) + call strcpy ("world", Memc[wcsstr], SZ_FNAME) + call strlwr (Memc[wcsstr]) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call printf ( + "%s: %s %s Projection: %s Ra/Dec axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + switch (radecsys) { + case EQTYPE_GAPPT: + call printf (" Coordinates: equatorial %s\n") + call pargstr (Memc[radecstr]) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call printf (" Coordinates: equatorial %s Equinox: J%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call printf (" Epoch: J%0.8f MJD: %0.5f\n") + call pargd (sl_epj (epoch)) + call pargd (epoch) + default: + call printf (" Coordinates: equatorial %s Equinox: B%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call printf (" Epoch: B%0.8f MJD: %0.5f\n") + call pargd (sl_epb (epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call printf ( + "%s: %s %s Projection: %s Elong/Elat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call printf (" Coordinates: ecliptic\n") + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call printf ( + "%s: %s %s Projection: %s Glong/Glat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call printf (" Coordinates: galactic\n") + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + + case CTYPE_SUPERGALACTIC: + call printf ( + "%s: %s %s Projection: %s Slong/Slat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call printf (" Coordinates: supergalactic\n") + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + } + + call sfree (sp) +end + + +# SK_IMWRITE -- Write a summary of the image coordinate system to the +# output file. + +procedure sk_imwrite (fd, label, imagesys, ctype, lngax, latax, wtype, ptype, + radecsys, equinox, epoch) + +int fd #I the output file descriptor +char label[ARB] #I input label +char imagesys[ARB] #I the input image name and wcs +int ctype #I the image coordinate type +int lngax #I the image ra/glon/elon axis +int latax #I the image dec/glat/elat axis +int wtype #I the image projection type +int ptype #I the image image wcs type +int radecsys #I the image equatorial reference system +double equinox #I the image equinox +double epoch #I the image epoch of the observation + +pointer sp, imname, projstr, wcsstr, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (wcsstr, SZ_FNAME, TY_CHAR) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + call sscan (imagesys) + call gargwrd (Memc[imname], SZ_FNAME) + if (sk_wrdstr (wtype, Memc[projstr], SZ_FNAME, WTYPE_LIST) <= 0) + call strcpy ("linear", Memc[projstr], SZ_FNAME) + call strupr (Memc[projstr]) + if (sk_wrdstr (ptype, Memc[wcsstr], SZ_FNAME, PIXTYPE_LIST) <= 0) + call strcpy ("world", Memc[wcsstr], SZ_FNAME) + call strlwr (Memc[wcsstr]) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call fprintf (fd, + "# %s: %s %s Projection: %s Ra/Dec axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + switch (radecsys) { + case EQTYPE_GAPPT: + call fprintf (fd, "# Coordinates: equatorial %s\n") + call pargstr (Memc[radecstr]) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call fprintf (fd, + "# Coordinates: equatorial %s Equinox: J%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call fprintf (fd, "# Epoch: J%0.8f MJD: %0.5f\n") + call pargd (sl_epj(epoch)) + call pargd (epoch) + default: + call fprintf (fd, + "# Coordinates: equatorial %s Equinox: B%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call fprintf (fd, "# Epoch: B%0.8f MJD: %0.5f\n") + call pargd (sl_epb (epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call fprintf (fd, + "# %s: %s %s Projection: %s Elong/Elat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call fprintf (fd, "# Coordinates: ecliptic\n") + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call fprintf (fd, + "# %s: %s %s Projection: %s Glong/Glat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call fprintf (fd, "# Coordinates: galactic\n") + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + + case CTYPE_SUPERGALACTIC: + call fprintf (fd, + "# %s: %s %s Projection: %s Slong/Slat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call fprintf (fd, "# Coordinates: supergalactic\n") + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + call sfree (sp) +end diff --git a/pkg/xtools/skywcs/skywcs.h b/pkg/xtools/skywcs/skywcs.h new file mode 100644 index 00000000..85b664c0 --- /dev/null +++ b/pkg/xtools/skywcs/skywcs.h @@ -0,0 +1,133 @@ +# Public definitions file for the SKYWCS library. + +# Define the SKYWCS library parameters. + +define S_VXOFF 1 +define S_VYOFF 2 +define S_VXSTEP 3 +define S_VYSTEP 4 +define S_EQUINOX 5 +define S_EPOCH 6 +define S_CTYPE 7 +define S_RADECSYS 8 +define S_WTYPE 9 +define S_PLNGAX 10 +define S_PLATAX 11 +define S_XLAX 12 +define S_YLAX 13 +define S_PIXTYPE 14 +define S_NLNGAX 15 +define S_NLATAX 16 +define S_NLNGUNITS 17 +define S_NLATUNITS 18 +define S_COOSYSTEM 19 +define S_STATUS 20 + +# Define the list of supported fundamental coordinate systems. + +define FTYPE_LIST "|fk4|noefk4|fk5|icrs|apparent|ecliptic|galactic|\ +supergalactic|" + +define FTYPE_FK4 1 +define FTYPE_FK4NOE 2 +define FTYPE_FK5 3 +define FTYPE_ICRS 4 +define FTYPE_GAPPT 5 +define FTYPE_ECLIPTIC 6 +define FTYPE_GALACTIC 7 +define FTYPE_SUPERGALACTIC 8 + +# Define the list of supported coordinate systems. + +define CTYPE_LIST "|equatorial|ecliptic|galactic|supergalactic|" + +define CTYPE_EQUATORIAL 1 +define CTYPE_ECLIPTIC 2 +define CTYPE_GALACTIC 3 +define CTYPE_SUPERGALACTIC 4 + +# Define the supported equatoral reference systems. + +define EQTYPE_LIST "|fk4|fk4-no-e|fk5|icrs|gappt|" + +define EQTYPE_FK4 1 +define EQTYPE_FK4NOE 2 +define EQTYPE_FK5 3 +define EQTYPE_ICRS 4 +define EQTYPE_GAPPT 5 + +# Define the input coordinate file longitude latitude units. + +define SKY_LNG_UNITLIST "|degrees|radians|hours|" +define SKY_LAT_UNITLIST "|degrees|radians|" + +define SKY_DEGREES 1 +define SKY_RADIANS 2 +define SKY_HOURS 3 + +# Define the list of supported image sky projection types. + +define WTYPE_LIST "|lin|azp|tan|sin|stg|arc|zpn|zea|air|cyp|car|\ +mer|cea|cop|cod|coe|coo|bon|pco|gls|par|ait|mol|csc|qsc|tsc|tnx|zpx|tpv|" + +define PTYPE_LIST "|z|z|z|z|z|z|z|z|z|c|c|c|c|n|n|n|n|c|c|c|c|c|c|c|c|c|\ +x|x|z|" + +define WTYPE_LIN 1 +define WTYPE_AZP 2 +define WTYPE_TAN 3 +define WTYPE_SIN 4 +define WTYPE_STG 5 +define WTYPE_ARC 6 +define WTYPE_ZPN 7 +define WTYPE_ZEA 8 +define WTYPE_AIR 9 +define WTYPE_CYP 10 +define WTYPE_CAR 11 +define WTYPE_MER 12 +define WTYPE_CEA 13 +define WTYPE_COP 14 +define WTYPE_COD 15 +define WTYPE_COE 16 +define WTYPE_COO 17 +define WTYPE_BON 18 +define WTYPE_PCO 19 +define WTYPE_GLS 20 +define WTYPE_PAR 21 +define WTYPE_AIT 22 +define WTYPE_MOL 23 +define WTYPE_CSC 24 +define WTYPE_QSC 25 +define WTYPE_TSC 26 +define WTYPE_TNX 27 +define WTYPE_ZPX 28 +define WTYPE_TPV 29 + +define PTYPE_NAMES "|z|c|n|x|" + +define PTYPE_ZEN 1 +define PTYPE_CYL 2 +define PTYPE_CON 3 +define PTYPE_EXP 4 + +# Define the supported image axis types. + +define AXTYPE_LIST "|ra|dec|glon|glat|elon|elat|slon|slat|" + +define AXTYPE_RA 1 +define AXTYPE_DEC 2 +define AXTYPE_GLON 3 +define AXTYPE_GLAT 4 +define AXTYPE_ELON 5 +define AXTYPE_ELAT 6 +define AXTYPE_SLON 7 +define AXTYPE_SLAT 8 + +# Define the supported image pixel coordinate systems. + +define PIXTYPE_LIST "|logical|tv|physical|world|" + +define PIXTYPE_LOGICAL 1 +define PIXTYPE_TV 2 +define PIXTYPE_PHYSICAL 3 +define PIXTYPE_WORLD 4 diff --git a/pkg/xtools/skywcs/skywcsdef.h b/pkg/xtools/skywcs/skywcsdef.h new file mode 100644 index 00000000..433247bd --- /dev/null +++ b/pkg/xtools/skywcs/skywcsdef.h @@ -0,0 +1,24 @@ +# The SKYWCS library structure. + +define LEN_SKYCOOSTRUCT (30 + SZ_FNAME + 1) + +define SKY_VXOFF Memd[P2D($1)] # logical ra/longitude offset +define SKY_VYOFF Memd[P2D($1+2)] # logical dec/tatitude offset +define SKY_VXSTEP Memd[P2D($1+4)] # logical ra/longitude stepsize +define SKY_VYSTEP Memd[P2D($1+6)] # logical dec/latitude stepsize +define SKY_EQUINOX Memd[P2D($1+8)] # equinox of ra/dec system (B or J) +define SKY_EPOCH Memd[P2D($1+10)] # epoch of observation (MJD) +define SKY_CTYPE Memi[$1+12] # celestial coordinate system code +define SKY_RADECSYS Memi[$1+13] # ra/dec system code +define SKY_WTYPE Memi[$1+14] # sky projection function code +define SKY_PLNGAX Memi[$1+15] # physical ra/longitude axis +define SKY_PLATAX Memi[$1+16] # physical dec/latitude axis +define SKY_XLAX Memi[$1+17] # logical ra/longitude axis +define SKY_YLAX Memi[$1+18] # logical dec/latitude axis +define SKY_PIXTYPE Memi[$1+19] # iraf wcs system code +define SKY_NLNGAX Memi[$1+20] # length of ra/longitude axis +define SKY_NLATAX Memi[$1+21] # length of dec/latitude axis +define SKY_NLNGUNITS Memi[$1+22] # the native ra/longitude units +define SKY_NLATUNITS Memi[$1+23] # the native dec/latitude units +define SKY_STATUS Memi[$1+24] # the status (OK or ERR) +define SKY_COOSYSTEM Memc[P2C($1+25)] # the coordinate system name diff --git a/pkg/xtools/strdetab.x b/pkg/xtools/strdetab.x new file mode 100644 index 00000000..9ce99675 --- /dev/null +++ b/pkg/xtools/strdetab.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRDETAB -- Procedure to remove tabs from a line of text and replace with +# blanks. + +procedure strdetab (line, outline, maxch, tabsize) + +int ip, op, maxch, tabsize +char line[ARB], outline [ARB] + +begin + op=1 + ip=1 + + while (line[ip] != EOS && op <= maxch) { + if (line[ip] == '\t') { + repeat { + outline[op] = ' ' + op = op + 1 + } until ((mod (op, tabsize) == 1) || (op > maxch)) + ip = ip + 1 + } else { + outline[op] = line[ip] + op = op + 1 + ip = ip + 1 + } + } + + outline[op] = EOS +end diff --git a/pkg/xtools/strentab.x b/pkg/xtools/strentab.x new file mode 100644 index 00000000..e2173c47 --- /dev/null +++ b/pkg/xtools/strentab.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRENTAB -- Procedure to replace blanks with tabs and blanks. + +procedure strentab (line, outline, maxch, tabsize) + +int maxch, tabsize +char line[ARB], outline[ARB] + +int ip, op, ltab + +begin + op = 1 + ip = 1 + + repeat { + ltab = ip + while (line[ltab] == ' ' && op <= maxch) { + ltab = ltab + 1 + if (mod(ltab, tabsize) == 1) { + outline[op] = '\t' + ip = ltab + op = op + 1 + } + } + for (; ip < ltab && op <= maxch; ip = ip + 1) { + outline[op] = ' ' + op = op + 1 + } + if (line[ip] == EOS || op >= maxch+1) + break + outline[op] = line[ip] + op = op + 1 + ip = ip + 1 + } until (line[ip] == EOS || op >= maxch+1) + + outline[op] = EOS +end diff --git a/pkg/xtools/syshost.x b/pkg/xtools/syshost.x new file mode 100644 index 00000000..8136e3ae --- /dev/null +++ b/pkg/xtools/syshost.x @@ -0,0 +1,232 @@ +include <clset.h> +include <ctotok.h> + + +# SYSHOST -- If a task which calls this routine is executed from the host +# command line (i.e. not through a CL) set any parameters not set on the +# command line (e.g. with keyword=value or @file arguments). The application +# provides three files to search in order. The first two are keyword=value +# files and the last is a parameter file. The parameter file may be encoded +# as a compiled procedure (see txtcompile). For this reason xt_txtopen is +# used which transparently handles disk text files and text encoding +# procedures. +# +# The process type is the return value. +# The show_pset argument is the name of a boolean parameter to query +# for showing the default parameter set. The value of this is returned +# for show_val. If the parameter is not used (a null string) or was +# not specified by the user the return value is false. + +int procedure syshost (keyfile1, keyfile2, parfile, show_pset, show_val) + +char keyfile1[ARB] #I Keyword file +char keyfile2[ARB] #I Keyword file +char parfile[ARB] #I Parameter file +char show_pset[ARB] #I Parameter for requestiong show +bool show_val #O Result of show request +int stat #R Return value + +char line[SZ_LINE], param[SZ_FNAME], value[SZ_LINE] +int i, ip, fd, tok + +bool clgetb(), streq() +int clstati(), access(), fscan(), ctotok(), strncmp(), xt_txtopen() +pointer clc_find() +errchk xt_getpars, xt_txtopen + +begin + # Check if the task is called from the host. + stat = clstati (CL_PRTYPE) + if (stat != PR_HOST) + return (stat) + + # Read user keyword=value files. + if (keyfile1[1] != EOS && access(keyfile1,0,0) == YES) + call xt_getpars (keyfile1) + if (keyfile2[1] != EOS && access(keyfile2,0,0) == YES) + call xt_getpars (keyfile2) + + # Read parameter file. + if (parfile[1] != EOS && + (access(parfile,0,0)==YES || strncmp (parfile, "proc:", 5)==0)) { + + # Open parameter file. + fd = NULL + fd = xt_txtopen (parfile) + + # Check for request to show default parameters. + if (show_pset[1] != EOS && clc_find(show_pset,param,SZ_FNAME)>0) + show_val = clgetb (show_pset) + else + show_val = false + + # Scan parameter file lines and parse them. + while (fscan (fd) != EOF) { + call gargstr (line, SZ_LINE) + + ip = 1 + if (ctotok (line, ip, param, SZ_FNAME) != TOK_IDENTIFIER) + next + if (streq (param, "mode")) + next + for (i=0; i<3 && ctotok(line,ip,value,SZ_LINE)!=TOK_EOS;) { + if (value[1] == ',') + i = i + 1 + } + tok = ctotok (line, ip, value, SZ_LINE) + switch (tok) { + case TOK_NUMBER, TOK_STRING, TOK_IDENTIFIER: + ; + default: + value[1] = EOS + } + + # Enter in clcache if not already defined. + if (clc_find (param, line, SZ_LINE) == NULL) + call clc_enter (param, value) + + # Show parameter if desired. + if (show_val) { + switch (tok) { + case TOK_STRING: + call printf ("%s = ""%s""\n") + call pargstr (param) + call pargstr (value) + default: + call printf ("%s = %s\n") + call pargstr (param) + call pargstr (value) + } + } + } + + # Close parameter file. + call xt_txtclose (fd) + } + + return (stat) +end + + +# The following are copies of sys_getpars and sys_paramset with the +# following changes. +# - Return an error rather than a warning for a bad syntax +# - Enter parameter in CL cache only if not previously set + + +include <ctype.h> + +define SZ_VALSTR 1024 +define SZ_CMDBUF (SZ_COMMAND+1024) + +# XT_GETPARS -- Read a sequence of param=value parameter assignments from +# the named file and enter them into the CLIO cache for the task. + +procedure xt_getpars (fname) + +char fname # pset file + +bool skip +int lineno, fd +pointer sp, lbuf, err, ip +int open(), getlline() +errchk open, getlline + +begin + call smark (sp) + call salloc (lbuf, SZ_CMDBUF, TY_CHAR) + + fd = open (fname, READ_ONLY, TEXT_FILE) + + # Skip whitespace for param = value args in a par file. + skip = true + + lineno = 0 + while (getlline (fd, Memc[lbuf], SZ_CMDBUF) != EOF) { + lineno = lineno + 1 + for (ip=lbuf; IS_WHITE (Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '#' || Memc[ip] == '\n') + next + iferr (call xt_paramset (Memc, ip, skip)) { + for (; Memc[ip] != EOS && Memc[ip] != '\n'; ip=ip+1) + ; + Memc[ip] = EOS + call salloc (err, SZ_LINE, TY_CHAR) + call sprintf (Memc[err], SZ_LINE, + "Bad param assignment, line %d: `%s'\n") + call pargi (lineno) + call pargstr (Memc[lbuf]) + call close (fd) + call error (1, Memc[err]) + } + } + + call close (fd) + call sfree (sp) +end + + +# XT_PARAMSET -- Extract the param and value substrings from a param=value +# or switch argument and enter them into the CL parameter cache. (see also +# clio.clcache). + +procedure xt_paramset (args, ip, skip) + +char args[ARB] # argument list +int ip # pointer to first char of argument +bool skip # skip whitespace within "param=value" args + +pointer sp, param, value, op, clc_find() +int stridx() + +begin + call smark (sp) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_VALSTR, TY_CHAR) + + # Extract the param field. + op = param + while (IS_ALNUM (args[ip]) || stridx (args[ip], "_.$") > 0) { + Memc[op] = args[ip] + op = op + 1 + ip = ip + 1 + } + Memc[op] = EOS + + # Advance to the switch character or assignment operator. + while (IS_WHITE (args[ip])) + ip = ip + 1 + + switch (args[ip]) { + case '+': + # Boolean switch "yes". + ip = ip + 1 + call strcpy ("yes", Memc[value], SZ_VALSTR) + + case '-': + # Boolean switch "no". + ip = ip + 1 + call strcpy ("no", Memc[value], SZ_VALSTR) + + case '=': + # Extract the value field. This is either a quoted string or a + # string delimited by any of the metacharacters listed below. + + ip = ip + 1 + if (skip) { + while (IS_WHITE (args[ip])) + ip = ip + 1 + } + call sys_gstrarg (args, ip, Memc[value], SZ_VALSTR) + + default: + call error (1, "IRAF Main: command syntax error") + } + + # Enter the param=value pair into the CL parameter cache. + if (clc_find (Memc[param], Memc[param], SZ_FNAME) == NULL) + call clc_enter (Memc[param], Memc[value]) + + call sfree (sp) +end diff --git a/pkg/xtools/t_txtcompile.x b/pkg/xtools/t_txtcompile.x new file mode 100644 index 00000000..1d4b8be4 --- /dev/null +++ b/pkg/xtools/t_txtcompile.x @@ -0,0 +1,62 @@ +include <fset.h> + +task txtcompile = t_txtcompile + + +# T_TXTCOMPILE -- Compile a text file into an SPP routine. + +procedure t_txtcompile () + +char input[SZ_FNAME] +char output[SZ_FNAME] +char procname[SZ_FNAME] + +char line[SZ_LINE] +int i, in, out, fsize + +int open(), fstati(), fscan() +errchk open, stropen + +begin + call clgstr ("input", input, SZ_FNAME) + call clgstr ("output", output, SZ_FNAME) + call clgstr ("procname", procname, SZ_FNAME) + + # Open files. + in = open (input, READ_ONLY, TEXT_FILE) + out = open (output, APPEND, TEXT_FILE) + + # Get input file size. + fsize = 2 * fstati (in, F_FILESIZE) + + # Write preamble. + call fprintf (out, "\n\nprocedure %s (xqzrkc)\n\n") + call pargstr (procname) + call fprintf (out, "pointer\txqzrkc\n\n") + call fprintf (out, "int\tfd, stropen()\n") + call fprintf (out, "errchk\tmalloc\n\nbegin\n") + call fprintf (out, "\tcall malloc (xqzrkc, %d, TY_CHAR)\n") + call pargi (fsize) + call fprintf (out, "\tfd = stropen (Memc[xqzrkc], ARB, NEW_FILE)\n") + + # Write text. + while (fscan (in) != EOF) { + call gargstr (line, SZ_LINE) + call fprintf (out, "\tcall fprintf (fd, """) + for (i=1; line[i]!=EOS; i=i+1) { + switch (line[i]) { + case '"', '%': + call putc (out, line[i]) + } + call putc (out, line[i]) + } + call fprintf (out, "\\\\n"")\n") + } + + # Write postamble. + call fprintf (out, "\tcall close (fd)\nend\n") + + # Close the files. + call close (out) + call close (in) +end diff --git a/pkg/xtools/txtcompile b/pkg/xtools/txtcompile new file mode 100755 index 00000000..b763cc92 --- /dev/null +++ b/pkg/xtools/txtcompile @@ -0,0 +1,3 @@ +# + +$iraf/bin$arch/x_txtcompile.e txtcompile input=$1 output=$2 procname=$3 diff --git a/pkg/xtools/xt21imsum.x b/pkg/xtools/xt21imsum.x new file mode 100644 index 00000000..ba0461e1 --- /dev/null +++ b/pkg/xtools/xt21imsum.x @@ -0,0 +1,148 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# XT_21IMSUM -- Sum 2D image columns or lines to 1D. + +procedure xt_21imsum (im, axis, col1, col2, line1, line2, x, y, npts) + +pointer im # IMIO pointer +int axis # Axis of vector +int col1, col2 # Range of columns +int line1, line2 # Range of lines +pointer x # Vector ordinates +pointer y # Vector abscissa +int npts # Number of points in vector + +int i, line, ncols, nlines + +real asumr() +pointer imgs2r() + +begin + # If the pointers are defined first free them. + + call mfree (x, TY_REAL) + call mfree (y, TY_REAL) + + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + switch (axis) { + case 1: + npts = ncols + call malloc (x, ncols, TY_REAL) + call calloc (y, ncols, TY_REAL) + + do i = 1, ncols + Memr[x+i-1] = col1 + i - 1 + + do i = 1, nlines { + line = line1 + i - 1 + call aaddr (Memr[imgs2r (im, col1, col2, line, line)], Memr[y], + Memr[y], ncols) + } + case 2: + npts = nlines + call malloc (x, nlines, TY_REAL) + call malloc (y, nlines, TY_REAL) + + do i = 1, nlines { + line = line1 + i - 1 + Memr[x+i-1] = line + Memr[y+i-1] = asumr (Memr[imgs2r (im, col1, col2, line, line)], + ncols) + } + } +end + +# XT_21IMMED -- Median 2D image columns or lines to 1D. + +define MAXPIX 10000 # Maximum number of pixels to read at one time. + +procedure xt_21immed (im, axis, col1, col2, line1, line2, x, y, npts) + +pointer im # IMIO pointer +int axis # Axis of vector +int col1, col2 # Range of columns +int line1, line2 # Range of lines +pointer x # Vector ordinates +pointer y # Vector abscissa +int npts # Number of points in vector + +int i, j, k, n, line, ncols, nlines, maxncols +pointer buf1, buf2 + +real amedr() +pointer imgs2r() + +begin + # If the pointers are defined first free them. + + call mfree (x, TY_REAL) + call mfree (y, TY_REAL) + + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + switch (axis) { + case 1: + npts = ncols + call malloc (x, ncols, TY_REAL) + call calloc (y, ncols, TY_REAL) + call malloc (buf1, nlines, TY_REAL) + + maxncols = MAXPIX / nlines + j = 0 + do i = 1, ncols { + if (i > j) { + n = min (ncols - j, maxncols) + buf2 = imgs2r (im, col1+j, col1+j+n-1, line1, line2) + j = j + n + } + do k = 1, nlines + Memr[buf1+k-1] = Memr[buf2+(k-1)*n+i-1] + Memr[y+i-1] = amedr (Memr[buf1], nlines) + } + + call mfree (buf1, TY_REAL) + + do i = 1, ncols + Memr[x+i-1] = col1 + i - 1 + case 2: + npts = nlines + call malloc (x, nlines, TY_REAL) + call malloc (y, nlines, TY_REAL) + + do i = 1, nlines { + line = line1 + i - 1 + Memr[x+i-1] = line + Memr[y+i-1] = amedr (Memr[imgs2r (im, col1, col2, line, line)], + ncols) + } + } +end + + +# XT_21IMAVG -- Average 2D image columns or lines to 1D. + +procedure xt_21imavg (im, axis, col1, col2, line1, line2, x, y, npts) + +pointer im # IMIO pointer +int axis # Axis of vector +int col1, col2 # Range of columns +int line1, line2 # Range of lines +pointer x # Vector ordinates +pointer y # Vector abscissa +int npts # Number of points in vector + +begin + call xt_21imsum (im, axis, col1, col2, line1, line2, x, y, npts) + + switch (axis) { + case 1: + call adivkr (Memr[y], real (line2-line1+1), Memr[y], npts) + case 2: + call adivkr (Memr[y], real (col2-col1+1), Memr[y], npts) + } +end diff --git a/pkg/xtools/xtanswer.h b/pkg/xtools/xtanswer.h new file mode 100644 index 00000000..46c382bf --- /dev/null +++ b/pkg/xtools/xtanswer.h @@ -0,0 +1,5 @@ +# Answers for emphatic yes and no. + +define XT_ANSWERS "|no|yes|NO|YES|" +define ALWAYSNO 2 +define ALWAYSYES 3 diff --git a/pkg/xtools/xtanswer.x b/pkg/xtools/xtanswer.x new file mode 100644 index 00000000..f2ebb2cf --- /dev/null +++ b/pkg/xtools/xtanswer.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pkg/xtanswer.h> + +# XT_ANSWER -- Issue an STDOUT prompt and get a STDIN answer with values +# YES, NO, ALWAYSYES, or ALWAYSNO. + +procedure xt_answer (prompt, answer) + +char prompt[ARB] # Prompt to be issued +int answer # Answer + +int nwrd +char word[SZ_LINE] + +int getline(), strdic(), strlen() + +begin + if ((answer == NO) || (answer == YES)) { + if (answer == NO) { + call printf ("%s (no): ") + call pargstr (prompt) + } else { + call printf ("%s (yes): ") + call pargstr (prompt) + } + call flush (STDOUT) + + if (getline (STDIN, word) != EOF) { + word[strlen(word)] = EOS + nwrd = strdic (word, word, 4, XT_ANSWERS) + switch (nwrd) { + case 1: + answer = NO + case 2: + answer = YES + case 3: + answer = ALWAYSNO + case 4: + answer = ALWAYSYES + } + } + } +end + + +# XT_CLANSWER -- Issue a CLGWRD request and get an answer with values +# YES, NO, ALWAYSYES, or ALWAYSNO. + +procedure xt_clanswer (parameter, answer) + +char parameter[ARB] # CL parameter +int answer # Answer + +pointer sp, str + +int clgwrd() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + switch (clgwrd (parameter, Memc[str], SZ_LINE, "|no|yes|NO|YES|")) { + case 1: + answer = NO + case 2: + answer = YES + case 3: + answer = ALWAYSNO + case 4: + answer = ALWAYSYES + default: + answer = YES + } + + call sfree (sp) +end diff --git a/pkg/xtools/xtargs.x b/pkg/xtools/xtargs.x new file mode 100644 index 00000000..ec2e2b5a --- /dev/null +++ b/pkg/xtools/xtargs.x @@ -0,0 +1,141 @@ +include <ctotok.h> + + +# XTARGS -- Parse strings consisting of a list keyword=value pairs. +# +# This is a limited interface to parse strings containing a list of +# whitespace separate keyword=value pairs and then provide get procedures +# for the value as a string or double. Other datatypes must be coerced or +# parsed from the string or the double values. +# +# The keyword=value pairs may contain whitespace between around the equal +# sign but the value must be quoted if it contains blanks. A keyword must +# be an "identifier" begining with a letter and consist of letters, numbers, +# underscore, dollar, and period. +# +# The get procedure posts an error if the requested key is not present. +# Note that the full power of the symbol table package may be used. +# The values of the symbols is a single integer having the offset into +# the string buffer of the symbol table which provides the value as as +# string. +# +# stp = xtargs_open (argstr) # parse string and return symtab +# xtargs_s (stp, key, val, maxchar) # Get value as a string +# dval = xtargs_d (stp, key) # Get value as a double +# +# Note that there is no close method and instead stclose should be used. + + + +# XTARGS_OPEN -- Parse an argument string and return a symbol table. +# +# Note that this interface does not include a close because the user +# inherits the symbol table interface. + +pointer procedure xtargs_open (argstr) + +char argstr[ARB] #I Argument string + +int i, tok +pointer sp, key, val, stp, sym + +bool strne() +int nscan(), stpstr() +pointer stopen(), stfind(), stenter() + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (val, SZ_LINE, TY_CHAR) + + # Open symbol table. + stp = stopen ("xtargs", 10, 100, 1000) + + # Scan the argument string. + call sscan (argstr) + repeat { + # Get keyword. + call gargtok (tok, Memc[key], SZ_FNAME) + if (tok == TOK_EOS) + break + + # Get required delimiter. + call gargtok (i, Memc[val], SZ_LINE) + if (i != TOK_OPERATOR || strne (Memc[val], "=")) + break + + # Get value. + call gargwrd (Memc[val], SZ_LINE) + + # Check for error. + if (tok != TOK_IDENTIFIER || mod (nscan(), 3) != 0) + break + + # Ignore case. + call strlwr (Memc[key]) + + # Enter in symbol table. + sym = stfind (stp, Memc[key]) + if (sym == NULL) { + sym = stenter (stp, Memc[key], 1) + Memi[sym] = stpstr (stp, Memc[val], 1) + } + } + + call sfree (sp) + + # Check for error. + if (mod (nscan(), 3) != 1) { + call stclose (stp) + call error (1, "Syntax error") + } + + return (stp) +end + + +# XTARGS_S -- Get string valued parameter. +# An error is triggered if the key is not in the symbol table. + +procedure xtargs_s (stp, key, val, maxchar) + +pointer stp #I Symbol table +char key[ARB] #I Key to find +char val[maxchar] #O String value +int maxchar #I Maximum number of characters + +pointer sym, stfind(), strefsbuf() + +begin + sym = stfind (stp, key) + if (sym == NULL) + call error (1, "Key not found") + + call strcpy (Memc[strefsbuf(stp,Memi[sym])], val, maxchar) +end + + +# XTARGS_D -- Get double valued parameter. +# An error is triggered if the key is not in the symbol table. + +double procedure xtargs_d (stp, key) + +pointer stp #I Symbol table +char key[ARB] #I Key to find +double dval #R Integer value + +int i, j, ctod(), strlen() +pointer sym, stfind(), strefsbuf() + +begin + sym = stfind (stp, key) + if (sym == NULL) + call error (1, "Key not found") + + i = 1 + j = ctod (Memc[strefsbuf(stp,Memi[sym])], i, dval) + if (j != strlen(Memc[strefsbuf(stp,Memi[sym])])) + call error (2, "Value not a number") + + return (dval) +end diff --git a/pkg/xtools/xtbitarray.x b/pkg/xtools/xtbitarray.x new file mode 100644 index 00000000..b02fcb90 --- /dev/null +++ b/pkg/xtools/xtbitarray.x @@ -0,0 +1,142 @@ +include <mach.h> + +# XT_BAITARRAY -- Routines to manage a 2D bit array. +# One use for this is to hold a large boolean mask in the minimum amount of +# memory for random I/O. + +define BA_LEN 6 # Length of structure +define BA_NC Memi[$1] # Number of columns +define BA_NL Memi[$1+1] # Number of lines +define BA_NBE Memi[$1+2] # Number of bits per element +define BA_NEW Memi[$1+3] # Number of elements per word +define BA_MAX Memi[$1+4] # Maximum value +define BA_DATA Memi[$1+5] # Data pointer + + +# XT_BAOPEN -- Open the bit array by allocating a structure and memory. + +pointer procedure xt_baopen (nc, nl, maxval) + +int nc, nl #I Size of bit array to open +int maxval #I Maximum value +pointer ba #R Bitarray structure + +int nbits +errchk calloc + +begin + nbits = SZB_CHAR * SZ_INT * 8 + + call calloc (ba, BA_LEN, TY_STRUCT) + BA_NC(ba) = nc + BA_NL(ba) = nl + BA_MAX(ba) = maxval + BA_NBE(ba) = int (log(real(maxval))/log(2.)+1.) + BA_NBE(ba) = min (BA_NBE(ba), nbits) + BA_NEW(ba) = nbits / BA_NBE(ba) + call calloc (BA_DATA(ba), + (BA_NC(ba) * BA_NL(ba) + BA_NEW(ba) - 1) / BA_NEW(ba), TY_INT) + return (ba) +end + + +# XT_BACLOSE -- Close the bit array by freeing memory. + +procedure xt_baclose (ba) + +pointer ba #U Bitarray structure + +begin + call mfree (BA_DATA(ba), TY_INT) + call mfree (ba, TY_STRUCT) +end + + +# XT_BAPS -- Put short data. + +procedure xt_baps (ba, c, l, data, n) + +pointer ba #I Bitarray structure +int c, l #I Starting element +short data[n] #I Input data array +int n #I Number of data values + +int i, j, k, m, val + +begin + k = (c - 1) + BA_NC(ba) * (l - 1) - 1 + do m = 1, n { + k = k + 1 + j = k / BA_NEW(ba) + i = BA_NBE(ba) * mod (k, BA_NEW(ba)) + 1 + val = min (data[m], BA_MAX(ba)) + call bitpak (val, Memi[BA_DATA(ba)+j], i, BA_NBE(ba)) + } +end + + +# XT_BAGS -- Get short data. + +procedure xt_bags (ba, c, l, data, n) + +pointer ba #I Bitarray structure +int c, l #I Starting element +short data[n] #I Output data array +int n #I Number of data values + +int i, j, k, m, bitupk() + +begin + k = (c - 1) + BA_NC(ba) * (l - 1) - 1 + do m = 1, n { + k = k + 1 + j = k / BA_NEW(ba) + i = BA_NBE(ba) * mod (k, BA_NEW(ba)) + 1 + data[m] = bitupk (Memi[BA_DATA(ba)+j], i, BA_NBE(ba)) + } +end + + +# XT_BAPI -- Put integer data. + +procedure xt_bapi (ba, c, l, data, n) + +pointer ba #I Bitarray structure +int c, l #I Starting element +int data[n] #I Input data array +int n #I Number of data values + +int i, j, k, m, val + +begin + k = (c - 1) + BA_NC(ba) * (l - 1) - 1 + do m = 1, n { + k = k + 1 + j = k / BA_NEW(ba) + i = BA_NBE(ba) * mod (k, BA_NEW(ba)) + 1 + val = min (data[m], BA_MAX(ba)) + call bitpak (val, Memi[BA_DATA(ba)+j], i, BA_NBE(ba)) + } +end + + +# XT_BAGI -- Get integer data. + +procedure xt_bagi (ba, c, l, data, n) + +pointer ba #I Bitarray structure +int c, l #I Starting element +int data[n] #I Output data array +int n #I Number of data values + +int i, j, k, m, bitupk() + +begin + k = (c - 1) + BA_NC(ba) * (l - 1) - 1 + do m = 1, n { + k = k + 1 + j = k / BA_NEW(ba) + i = BA_NBE(ba) * mod (k, BA_NEW(ba)) + 1 + data[m] = bitupk (Memi[BA_DATA(ba)+j], i, BA_NBE(ba)) + } +end diff --git a/pkg/xtools/xtextns.x b/pkg/xtools/xtextns.x new file mode 100644 index 00000000..3c95e4f9 --- /dev/null +++ b/pkg/xtools/xtextns.x @@ -0,0 +1,587 @@ +include <error.h> +include <pkg/mef.h> +include <imhdr.h> + + +define SZ_RANGE 100 # Size of range list + + +# XT_EXTNS -- Expand template of files into a list of extensions. +# +# This supports all MEF extension types. If IMAGE type or any type is +# requested this will also return non-FITS images as well. +# +# This differs from XT_EXTNS1 in that extension zero is not returned +# unless it is a simple image and, in that case, the extension is removed. + +int procedure xt_extns (files, exttype, index, extname, extver, lindex, lname, + lver, dataless, ikparams, err, imext) + +char files[ARB] #I List of MEF files +char exttype[ARB] #I Extension type (or null for all) +char index[ARB] #I Range list of extension indexes +char extname[ARB] #I Patterns for extension names +char extver[ARB] #I Range list of extension versions +int lindex #I List index number? +int lname #I List extension name? +int lver #I List extension version? +int dataless #I Include dataless image headers? +char ikparams[ARB] #I Image kernel parameters +int err #I Print errors? +int imext #O Image extensions? +int list #O Image list + +int i, j, nphu, nextns, fd +pointer sp, temp, patbuf, fname, image, im, immap() +int xt_extns1(), patmake(), gpatmatch(), imtopen(), imtgetim(), open() +errchk xt_extns1, open, immap, delete + +begin + call smark (sp) + call salloc (temp, SZ_FNAME, TY_CHAR) + call salloc (patbuf, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + + # Get the list. + list = xt_extns1 (files, exttype, index, extname, extver, lindex, + lname, lver, ikparams, err) + + # Check and edit the list. + i = patmake ("\[[01]\]", Memc[patbuf], SZ_FNAME) + nphu = 0 + nextns = 0 + call mktemp ("@tmp$iraf", Memc[temp], SZ_FNAME) + fd = open (Memc[temp+1], NEW_FILE, TEXT_FILE) + while (imtgetim (list, Memc[fname], SZ_FNAME) != EOF) { + if (dataless == NO) { + iferr (im = immap (Memc[fname], READ_ONLY, 0)) + im = NULL + if (im != NULL) { + if (IM_NDIM(im) == 0 || IM_LEN(im,1) == 0) { + call imunmap (im) + next + } + call imunmap (im) + } + } + if (gpatmatch (Memc[fname], Memc[patbuf], i, j) > 0) { + call strcpy (Memc[fname], Memc[image], SZ_FNAME) + call strcpy (Memc[image+j], Memc[image+i-1], SZ_FNAME) + ifnoerr (im = immap (Memc[image], READ_ONLY, 0)) { + call strcpy (Memc[image], Memc[fname], SZ_FNAME) + call imunmap (im) + nphu = nphu + 1 + } + } + nextns = nextns + 1 + call fprintf (fd, "%s\n") + call pargstr (Memc[fname]) + } + call close (fd) + + # Return new list and extension flag. + imext = YES + if (nphu == nextns) + imext = NO + call imtclose (list) + list = imtopen (Memc[temp]) + call delete (Memc[temp+1]) + call sfree (sp) + return (list) +end + + +# XT_IMEXTNS -- Expand a template of MEF files into a list of image extensions. + +int procedure xt_imextns (files, index, extname, extver, lindex, lname, lver, + ikparams, err) + +char files[ARB] #I List of MEF files +char index[ARB] #I Range list of extension indexes +char extname[ARB] #I Patterns for extension names +char extver[ARB] #I Range list of extension versions +int lindex #I List index number? +int lname #I List extension name? +int lver #I List extension version? +char ikparams[ARB] #I Image kernel parameters +int err #I Print errors? +int list #O Image list + +int xt_extns1() +errchk xt_extns1 + +begin + list = xt_extns1 (files, "IMAGE", index, extname, extver, lindex, + lname, lver, ikparams, err) + return (list) +end + + +# XT_EXTNS1 -- Expand a template of MEFs into a list of extensions. + +int procedure xt_extns1 (files, exttype, index, extname, extver, lindex, + lname, lver, ikparams, err) + +char files[ARB] #I List of MEFs +char exttype[ARB] #I Desired extension type (or null for all) +char index[ARB] #I Range list of extension indexes +char extname[ARB] #I Patterns for extension names +char extver[ARB] #I Range list of extension versions +int lindex #I List index number? +int lname #I List extension name? +int lver #I List extension version? +char ikparams[ARB] #I Image kernel parameters +int err #I Print errors? +int list #O Image list + +int i, fd +pointer sp, temp, fname, rindex, rextver, ikp, str +int imtopen(), imtgetim() +int ix_decode_ranges(), decode_ranges(), nowhite(), open() +errchk open, xt_extn, delete + +begin + call smark (sp) + call salloc (temp, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (ikp, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Expand parameters. + list = imtopen (files) + call salloc (rindex, 3*SZ_RANGE, TY_INT) + if (ix_decode_ranges (index, Memi[rindex], SZ_RANGE, i) == ERR) + call error (1, "Bad index range list") + + rextver = NULL + if (nowhite (extver, Memc[str], SZ_LINE) > 0) { + call salloc (rextver, 3*SZ_RANGE, TY_INT) + if (decode_ranges (Memc[str], Memi[rextver], SZ_RANGE, i)==ERR) + call error (1, "Bad extension version range list") + } + i = nowhite (ikparams, Memc[ikp], SZ_LINE) + + # Expand MEFs into list of extensions in a temp file. + call mktemp ("@tmp$iraf", Memc[temp], SZ_FNAME) + fd = open (Memc[temp+1], NEW_FILE, TEXT_FILE) + while (imtgetim (list, Memc[fname], SZ_FNAME) != EOF) { + call xt_extn (fd, Memc[fname], exttype, rindex, extname, + rextver, lindex, lname, lver, Memc[ikp], err) + } + call imtclose (list) + call close (fd) + + # Return list. + list = imtopen (Memc[temp]) + call delete (Memc[temp+1]) + call sfree (sp) + return (list) +end + + +# XT_EXTN -- Expand a single MEF into a list of extensions. +# The extensions are written to the input file descriptor. + +procedure xt_extn (fd, fname, exttype, indices, extname, extver, lindex, + lname, lver, ikparams, err) + +int fd #I File descriptor for list +char fname[SZ_FNAME] #I File name +char exttype[ARB] #I Extension type (or null for all) +pointer indices #I Range list of extension indexes +char extname[ARB] #I Pattern for extension names +pointer extver #I Range list of extension versions +int lindex #I List index number? +int lname #I List extension name? +int lver #I List extension version? +char ikparams[ARB] #I Image kernel parameters +int err #I Print errors? + +int i, j, n, index, ver, stat +pointer sp, clust, ksec, imsec, name, str +pointer mef, im + +bool streq(), is_in_range(), xt_extmatch() +int mef_rdhdr_exnv(), mef_rdhdr_gn(), ix_get_next_number() +pointer mefopen(), immap() +errchk mefopen, mef_rdhdr_exnv, mef_rdhdr_gn, immap + +begin + call smark (sp) + call salloc (clust, SZ_FNAME, TY_CHAR) + call salloc (ksec, SZ_FNAME, TY_CHAR) + call salloc (imsec, SZ_FNAME, TY_CHAR) + call salloc (name, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Parse the file name syntax. + call imparse (fname, Memc[clust], SZ_FNAME, Memc[ksec], + SZ_FNAME, Memc[imsec], SZ_FNAME, index, ver) + + # Open the file and check the error status. + iferr (mef = mefopen (Memc[clust], READ_ONLY, 0)) { + if (exttype[1] == EOS || !streq (exttype, "IMAGE")) + call fprintf (fd, fname) + else if (streq (exttype, "IMAGE")) { + ifnoerr (im = immap (fname, READ_ONLY, 0)) { + call imunmap (im) + call fprintf (fd, fname) + } + } + return + } + + # Loop through extensions. + if (Memc[ksec] != EOS || index >= 0) + n = 1 + else + n = ARB + j = index + do i = 1, n { + iferr { + # If a kernel section is given look for the extension/extver. + if (Memc[ksec] != EOS) { + call mef_ksection (Memc[ksec], Memc[name], ver) + stat = mef_rdhdr_exnv (mef, Memc[name], ver) + + # If an index is given then look for the indexed extension + } else if (j >= 0) + stat = mef_rdhdr_gn (mef, j) + + # If neither is given look for list of indices. + else { + stat = ix_get_next_number (Memi[indices], index) + if (stat != EOF) + stat = mef_rdhdr_gn (mef, index) + } + } then { + # Check if file is an IRAF image. + if (exttype[1] == EOS || !streq (exttype, "IMAGE")) + call fprintf (fd, fname) + else if (streq (exttype, "IMAGE")) { + ifnoerr (im = immap (fname, READ_ONLY, 0)) { + call imunmap (im) + call fprintf (fd, fname) + } + } + stat = EOF + } + + # Finish if EOF is encountered in either indices or file. + if (stat == EOF) + break + + # Check the extension type. + if (exttype[1] != EOS && !streq (exttype, MEF_EXTTYPE(mef))) { + if (!streq (exttype, "IMAGE") || + !streq (MEF_EXTTYPE(mef), "SIMPLE")) { + # Check for PLIO mask which is a kind of image. + if (streq (MEF_EXTTYPE(mef), "BINTABLE")) { + call sprintf (Memc[str], SZ_LINE, "%s[%d]") + call pargstr (Memc[clust]) + call pargi (MEF_CGROUP(mef)) + iferr (im = immap (Memc[str], READ_ONLY, 0)) + im = NULL + if (im == NULL) + next + else + call imunmap (im) + } + } + } + + # Check the extension name. + if (!xt_extmatch (MEF_EXTNAME(mef), extname)) + next + + # Check the extension version. + if (extver != NULL) { + if (IS_INDEFI(MEF_EXTVER(mef))) + next + if (!is_in_range (Memi[extver], MEF_EXTVER(mef))) + next + } + + # Set the extension name and version. + if (lname == YES) + call strcpy (MEF_EXTNAME(mef), Memc[name], SZ_LINE) + else + Memc[name] = EOS + if (lver == YES) + ver = MEF_EXTVER(mef) + else + ver = INDEFI + + # Output the file name with the desired elements. + call fprintf (fd, Memc[clust]) + if (lindex == YES || (Memc[name] == EOS && IS_INDEFI(ver))) { + call fprintf (fd, "[%d]") + call pargi (MEF_CGROUP(mef)) + } + if (Memc[name] != EOS) { + call fprintf (fd, "[%s") + call pargstr (Memc[name]) + if (!IS_INDEFI(ver)) { + call fprintf (fd, ",%d") + call pargi (ver) + } + if (ikparams[1] != EOS) { + call fprintf (fd, ",%s") + call pargstr (ikparams) + } + call fprintf (fd, "]") + } else if (!IS_INDEFI(ver)) { + call fprintf (fd, "[extver=%d") + call pargi (ver) + if (ikparams[1] != EOS) { + call fprintf (fd, ",%s") + call pargstr (ikparams) + } + call fprintf (fd, "]") + } else if (ikparams[1] != EOS) { + call fprintf (fd, "[%s]") + call pargstr (ikparams) + } + if (Memc[imsec] != EOS) { + call fprintf (fd, "%s") + call pargstr (Memc[imsec]) + } + call fprintf (fd, "\n") + } + + # Finish up. + call mefclose (mef) + call sfree (sp) +end + + +include <mach.h> +include <ctype.h> + +define FIRST 0 # Default starting range +define LAST MAX_INT # Default ending range +define STEP 1 # Default step +define EOLIST -1 # End of list + +# IX_DECODE_RANGES -- Parse a string containing a list of integer numbers or +# ranges, delimited by either spaces or commas. Return as output a list +# of ranges defining a list of numbers, and the count of list numbers. +# Range limits must be positive nonnegative integers. ERR is returned as +# the function value if a conversion error occurs. The list of ranges is +# delimited by EOLIST. + +int procedure ix_decode_ranges (range_string, ranges, max_ranges, nvalues) + +char range_string[ARB] # Range string to be decoded +int ranges[3, max_ranges] # Range array +int max_ranges # Maximum number of ranges +int nvalues # The number of values in the ranges + +int ip, nrange, first, last, step, ctoi() + +begin + ip = 1 + nvalues = 0 + + do nrange = 1, max_ranges - 1 { + # Defaults to all nonnegative integers + first = FIRST + last = LAST + step = STEP + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get first limit. + # Must be a number, '-', 'x', or EOS. If not return ERR. + if (range_string[ip] == EOS) { # end of list + if (nrange == 1) { + # Null string defaults + ranges[1, 1] = first + ranges[2, 1] = last + ranges[3, 1] = step + ranges[1, 2] = EOLIST + nvalues = MAX_INT + return (OK) + } else { + ranges[1, nrange] = EOLIST + return (OK) + } + } else if (range_string[ip] == '-') + ; + else if (range_string[ip] == 'x') + ; + else if (IS_DIGIT(range_string[ip])) { # ,n.. + if (ctoi (range_string, ip, first) == 0) + return (ERR) + } else + return (ERR) + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get last limit + # Must be '-', or 'x' otherwise last = first. + if (range_string[ip] == 'x') + ; + else if (range_string[ip] == '-') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, last) == 0) + return (ERR) + } else if (range_string[ip] == 'x') + ; + else + return (ERR) + } else + last = first + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get step. + # Must be 'x' or assume default step. + if (range_string[ip] == 'x') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, step) == 0) + ; + if (step == 0) + return (ERR) + } else if (range_string[ip] == '-') + ; + else + return (ERR) + } + + # Output the range triple. + ranges[1, nrange] = first + ranges[2, nrange] = last + ranges[3, nrange] = step + nvalues = nvalues + abs (last-first) / step + 1 + } + + return (ERR) # ran out of space +end + + +# IX_GET_NEXT_NUMBER -- Given a list of ranges and the current file number, +# find and return the next file number. Selection is done in such a way +# that list numbers are always returned in monotonically increasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure ix_get_next_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number+1 is anywhere in the list, that is the next number, + # otherwise the next number is the smallest number in the list which + # is greater than number+1. + + number = number + 1 + next_number = MAX_INT + + for (ip=1; ranges[ip] != EOLIST; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (step == 0) + call error (1, "Step size of zero in range list") + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder + step <= last) + next_number = number - remainder + step + } else if (first > number) + next_number = min (next_number, first) + } + + if (next_number == MAX_INT) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# XT_EXTMATCH -- Match extname against a comma-delimited list of patterns. + +bool procedure xt_extmatch (extname, patterns) + +char extname[ARB] #I Extension name to match +char patterns[ARB] #I Comma-delimited list of patterns +bool stat #O Match? + +int i, j, k, sz_pat, strlen(), patmake(), patmatch(), nowhite() +pointer sp, patstr, patbuf + +begin + if (patterns[1] == EOS) + return (true) + + stat = false + + sz_pat = strlen (patterns) + if (sz_pat == 0) + return (stat) + sz_pat = sz_pat + SZ_LINE + + call smark (sp) + call salloc (patstr, sz_pat, TY_CHAR) + call salloc (patbuf, sz_pat, TY_CHAR) + + i = nowhite (patterns, Memc[patstr], sz_pat) + if (i == 0) + stat = true + else if (i == 1 && Memc[patstr] == '*') + stat = true + else { + i = 1 + for (j=i;; j=j+1) { + if (patterns[j] != ',' && patterns[j] != EOS) + next + if (j > 0 && patterns[j] == ',' && patterns[j-1] == '\\') + next + if (j - i > 0) { + if (j-i == 1 && patterns[i] == '*') { + stat = true + break + } + call strcpy (patterns[i], Memc[patstr+1], j-i) + Memc[patstr] = '^' + Memc[patstr+j-i+1] = '$' + Memc[patstr+j-i+2] = EOS + k = patmake (Memc[patstr], Memc[patbuf], sz_pat) + if (patmatch (extname, Memc[patbuf]) > 0) { + stat = true + break + } + } + if (patterns[j] == EOS) + break + i = j + 1 + } + } + + call sfree (sp) + return (stat) +end diff --git a/pkg/xtools/xtgids.x b/pkg/xtools/xtgids.x new file mode 100644 index 00000000..ea56c36c --- /dev/null +++ b/pkg/xtools/xtgids.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctotok.h> + +# XT_GIDS -- Get identifier tokens from a string and match with a dictionary. +# +# The input string is scanned for identifier tokens (see definition of +# identifier token in ctotok) and each token is checked against the +# dictionary string. An array of YES/NO values for each dictionary entry, +# up to a maximum of maxids, is returned. + +procedure xt_gids (str, dicstr, ids, maxids) + +char str[ARB] # Input string +char dicstr[ARB] # Dictionary string +int ids[maxids] # Identifier indices in dictionary +int maxids # Maximum number of identifiers + +int i, ip, token +char tokstr[SZ_LINE] + +int ctotok(), strdic() + +begin + call amovki (NO, ids, maxids) + + ip = 1 + repeat { + token = ctotok (str, ip, tokstr, SZ_LINE) + switch (token) { + case TOK_EOS: + return + case TOK_IDENTIFIER: + i = strdic (tokstr, tokstr, SZ_LINE, dicstr) + if ((i > 0) && (i <= maxids)) + ids[i] = YES + } + } +end diff --git a/pkg/xtools/xtimleneq.x b/pkg/xtools/xtimleneq.x new file mode 100644 index 00000000..ece51695 --- /dev/null +++ b/pkg/xtools/xtimleneq.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# XT_IMLENEQ -- Determine if the lengths of the common image dimensions +# are equal. + +bool procedure xt_imleneq (im1, im2) + +pointer im1 # First IMIO pointer +pointer im2 # Second IMIO pointer + +int i, ndim + +begin + ndim = min (IM_NDIM (im1), IM_NDIM (im2)) + do i = 1, ndim { + if (IM_LEN (im1, i) != IM_LEN (im2, i)) + return (FALSE) + } + return (TRUE) +end diff --git a/pkg/xtools/xtimnames.x b/pkg/xtools/xtimnames.x new file mode 100644 index 00000000..2613a641 --- /dev/null +++ b/pkg/xtools/xtimnames.x @@ -0,0 +1,102 @@ +# Routines to deal with image kernel extensions +# XT_IMROOT -- Get root name of an image minus it's image kernel extention +# XT_IMEXT -- Get image kernel extension with the period. +# XT_IMNAMEEQ -- Check if two image names are equal. + + +# XT_IMROOT -- Get root name of an image minus it's image kernel extention +# This calls the IKI routines which is an interface violation. + +procedure xt_imroot (image, root, maxchar) + +char image[ARB] # Full image name +char root[maxchar] # Root name +int maxchar # Size of root name string + +int i, fnextn(), iki_validextn(), strlen() +pointer sp, extn + +begin + call smark (sp) + call salloc (extn, SZ_FNAME, TY_CHAR) + + call imgimage (image, root, maxchar) + i = fnextn (root, Memc[extn], SZ_FNAME) + if (i > 0) { + call iki_init() + if (iki_validextn (0, Memc[extn]) != 0) + root[strlen(root)-i] = EOS + } + + call sfree (sp) +end + + +# XT_IMEXT -- Get image kernel extension with the period. +# This calls the IKI routines which is an interface violation. + +procedure xt_imext (image, ext, maxchar) + +char image[ARB] # Full image name +char ext[maxchar] # Extension +int maxchar # Size of extension + +int i, fnextn(), iki_validextn() +pointer sp, root + +begin + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + + ext[1] = EOS + + # Get root and extension + call imgimage (image, Memc[root], SZ_LINE) + i = fnextn (Memc[root], ext[2], maxchar-1) + if (i > 0) { + call iki_init() + if (iki_validextn (0, ext[2]) != 0) + ext[1] = '.' + } + + call sfree (sp) +end + + +# XT_IMNAMEEQ -- Check if two image names are equal. +# Image sections and clusters are removed. If an image extension is missing +# it is assumed the same as the other image; i.e. only if both names +# have extensions are the extensions checked for equality. + +bool procedure xt_imnameeq (imname1, imname2) + +char imname1[ARB] # First image name +char imname2[ARB] # Second image name + +bool stat, streq() +pointer sp, str1, str2 + +begin + if (streq (imname1, imname2)) + return (true) + + call smark (sp) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + + # Check roots + call xt_imroot (imname1, Memc[str1], SZ_FNAME) + call xt_imroot (imname2, Memc[str2], SZ_FNAME) + stat = streq (Memc[str1], Memc[str2]) + + # If the roots are equal check the extensions. + if (stat) { + call xt_imext (imname1, Memc[str1], SZ_FNAME) + call xt_imext (imname2, Memc[str2], SZ_FNAME) + if (Memc[str1] != EOS && Memc[str2] != EOS) + stat = streq (Memc[str1], Memc[str2]) + } + + call sfree (sp) + return (stat) +end diff --git a/pkg/xtools/xtimtgetim.x b/pkg/xtools/xtimtgetim.x new file mode 100644 index 00000000..6904f04a --- /dev/null +++ b/pkg/xtools/xtimtgetim.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# XT_IMTGETIM -- Given two input lists and an output list return image elements +# from each of the lists. The shorter input list is repeated as necessary. +# EOF is returned when the longer input list is finished or when the output +# list is finished. The image name strings are assumed to all be at least +# of length sz_image. It is assumed that if the image lists were +# successfully opened then no errors will occur with imtlen, imtgetim, and +# imtrew. + +int procedure xt_imtgetim (list1, list2, list3, image1, image2, image3, + sz_image) + +int list1 # First input image list +int list2 # Second input image list +int list3 # Output image list +char image1[sz_image] # Returned image from first list +char image2[sz_image] # Returned image from second list +char image3[sz_image] # Returned image from third list +int sz_image # Maximum size of image strings + +int imtlen(), imtgetim() + +begin + # If list1 is longer than list2 then get next element of list1 + # and repeat list2 if necessary. + + if (imtlen (list1) > imtlen (list2)) { + if (imtgetim (list1, image1, sz_image) == EOF) + return (EOF) + if (imtgetim (list2, image2, sz_image) == EOF) { + call imtrew (list2) + if (imtgetim (list2, image2, sz_image) == EOF) + return (EOF) # Two EOFs are a null list. + } + + # If list2 is longer or equal to list1 then get next element of list2 + # and repeat list1 if necessary. + + } else { + if (imtgetim (list2, image2, sz_image) == EOF) + return (EOF) + if (imtgetim (list1, image1, sz_image) == EOF) { + call imtrew (list1) + if (imtgetim (list1, image1, sz_image) == EOF) + return (EOF) # Two EOFs are a null list. + } + } + + # Return the output image and the status of the output list. + return (imtgetim (list3, image3, sz_image)) +end diff --git a/pkg/xtools/xtlogfiles.x b/pkg/xtools/xtlogfiles.x new file mode 100644 index 00000000..b09a7315 --- /dev/null +++ b/pkg/xtools/xtlogfiles.x @@ -0,0 +1,93 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Procedures for opening and closing a list of logfiles. Given the +# name of the CL parameter that contains the list, a dynamic array +# of descriptors for the open files is allocated. The number of open +# log files is returned. The files are time stamped both when opened +# and when closed. + +# XT_LOGOPEN -- Open a list of log files and provide a sysid time stamp. + +int procedure xt_logopen (logparam, prefix, logfd, stdflag) + +char logparam[ARB] #I CL parameter specifying the list +char prefix[ARB] #I String to preceed sysid info +pointer logfd #O Pointer to array of open file descriptors +int stdflag #O Flag that STDOUT or ERR is in the list + +int loglist, nlogfd, fd, i +pointer linebuf, fname, sp + +int clpopnu(), clplen(), clgfil(), open() +errchk open + +begin + logfd = NULL + stdflag = NO + + loglist = clpopnu (logparam) + nlogfd = clplen (loglist) + + if (nlogfd > 0) { + call smark (sp) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call malloc (logfd, nlogfd, TY_INT) + + call sysid (Memc[linebuf], SZ_LINE) + + for (i=1; clgfil (loglist, Memc[fname], SZ_FNAME) != EOF; i=i+1) { + fd = open (Memc[fname], APPEND, TEXT_FILE) + Memi[logfd+i-1] = fd + if (fd == STDOUT || fd == STDERR) + stdflag = YES + + call fprintf (fd, "\n%s %s\n\n") + call pargstr (prefix) + call pargstr (Memc[linebuf]) + call flush (fd) + } + + call sfree (sp) + } + + call clpcls (loglist) + return (nlogfd) +end + + +# XT_LOGCLOSE -- Close a list of log files and provide a sysid time stamp. + +procedure xt_logclose (logfd, nlogfd, prefix) + +pointer logfd #I Pointer to array of open file descriptors +int nlogfd #I Number of open files +char prefix[ARB] #I String to preceed sysid info + +int fd, i +pointer linebuf, sp + +errchk close + +begin + if (nlogfd <= 0) + return + + call smark (sp) + call salloc (linebuf, SZ_LINE, TY_CHAR) + + call sysid (Memc[linebuf], SZ_LINE) + + do i = 1, nlogfd { + fd = Memi[logfd+i-1] + + call fprintf (fd, "\n%s %s\n\n") + call pargstr (prefix) + call pargstr (Memc[linebuf]) + + call close (fd) + } + + call mfree (logfd, TY_INT) + call sfree (sp) +end diff --git a/pkg/xtools/xtmaskname.x b/pkg/xtools/xtmaskname.x new file mode 100644 index 00000000..70ddfe34 --- /dev/null +++ b/pkg/xtools/xtmaskname.x @@ -0,0 +1,125 @@ +# XT_MASKNAME -- Make a mask name. +# +# This creates a FITS mask extension if possible, otherwise it creates a +# pixel list file. To override this default the environment variable +# "masktype" needs to be set to "pl". To create a FITS extension the +# filename must explicitly select the FITS kernel or the default image type +# must be a FITS file. The input and output strings may be the same. +# This supports multiextension masks for pl format by using a subdirectory. + +procedure xt_maskname (fname, extname, mode, mname, maxchar) + +char fname[ARB] #I File name +char extname[ARB] #I Default pixel mask extension name +int mode #I Mode +char mname[maxchar] #O Output mask name +int maxchar #I Maximum characters in mask name + +int i, fits +pointer sp, extnm, temp + +bool streq() +int strmatch(), stridxs(), strldxs(), strncmp() +int envfind(), access(), imaccess() + +begin + call smark (sp) + call salloc (extnm, SZ_FNAME, TY_CHAR) + call salloc (temp, maxchar, TY_CHAR) + + # Set extension name. + if (extname[1] == EOS) + call strcpy ("pl", Memc[extnm], SZ_FNAME) + else + call strcpy (extname, Memc[extnm], SZ_FNAME) + + # Determine whether to use FITS pixel mask extensions. + if (envfind ("masktype", Memc[temp], maxchar) > 0) { + if (streq (Memc[temp], "pl")) + fits = NO + else + fits = YES + } else + fits = YES + i = strldxs ("]", fname) + + # Check for explicit .pl extension. + if (strmatch (fname, ".pl$") > 0) + call strcpy (fname, mname, maxchar) + + # Check for explicit mask extension. + else if (strmatch (fname, "type=mask") > 0) + call strcpy (fname, mname, maxchar) + else if (strmatch (fname, "type\\\=mask") > 0) + call strcpy (fname, mname, maxchar) + + # Check for kernel section and add mask type. + else if (i > 0) { + call strcpy (fname, mname, maxchar) + if (mode != READ_ONLY) { + call strcpy (fname[i], Memc[temp], maxchar) + call sprintf (mname[i], maxchar-i, ",type=mask%s") + call pargstr (Memc[temp]) + } + + # Create output from rootname name. + } else if (fits == YES) { + if (mode == READ_ONLY) { + call sprintf (mname, maxchar, "%s[%s]") + call pargstr (fname) + call pargstr (Memc[extnm]) + } else { + call sprintf (mname, maxchar, "%s[%s,type=mask]") + call pargstr (fname) + call pargstr (Memc[extnm]) + } + } else if (extname[1] != EOS) { + call sprintf (mname, maxchar, "%s[%s]") + call pargstr (fname) + call pargstr (Memc[extnm]) + } else { + call sprintf (mname, maxchar, "%s.pl") + call pargstr (fname) + } + + # Convert extension references to pl form if required. + # Extensions are implemented as directories. + + i = stridxs ("[", mname) + if (i > 0 && mode == READ_ONLY) + fits = imaccess (mname, mode) + if (fits == NO && i > 0) { + call strcpy (mname, Memc[temp], maxchar) + mname[i] = EOS + if (mode == NEW_IMAGE) { + if (access (mname, 0, 0) == NO) { + ifnoerr (call fmkdir (mname)) + mname[i] = '/' + else + mname[i] = '_' + } else + mname[i] = '/' + } else { + if (access (mname, 0, 0) == NO) + mname[i] = '_' + else + mname[i] = '/' + } + + if (strncmp (mname[i+1], "type", 4) == 0 || + strncmp (mname[i+1], "append", 6) == 0 || + strncmp (mname[i+1], "inherit", 7) == 0) { + mname[i+1] = EOS + call strcat (Memc[extnm], mname, maxchar) + } else { + i = stridxs (",]", mname) + mname[i] = EOS + } + call strcat (".pl", mname, maxchar) + + if (mode == READ_ONLY && imaccess(mname,0)==NO) + call strcpy (Memc[temp], mname, maxchar) + } + + call sfree (sp) +end diff --git a/pkg/xtools/xtmksection.x b/pkg/xtools/xtmksection.x new file mode 100644 index 00000000..3dd404cb --- /dev/null +++ b/pkg/xtools/xtmksection.x @@ -0,0 +1,141 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# XT_MKSECTION -- Convert an generalized image section string to an IMIO +# section string. The generalized image section string has one of the +# following formats: +# 1. An IMIO image section +# 2. [line|column] [#|middle|last] +# 3. [#|middle|last] [line|column] +# where # is a line or column number. The strings may be abbreviated. +# This procedure will work for images of dimension greater than 2 provided +# that missing sections references default to 1. + +define SZ_WRD 10 + +procedure xt_mksection (image, secstr, section, sz_section) + +char image[ARB] # Image +char secstr[ARB] # Image section string +char section[sz_section] # Returned image section string +int sz_section # Maximum size of image section string + +char wrd1[SZ_WRD], wrd2[SZ_WRD] +int ndim, len1, len2, i, j, k +pointer im + +int strdic(), ctoi() +pointer immap() +errchk immap() + +begin + im = immap (image, READ_ONLY, 0) + ndim = IM_NDIM(im) + len1 = IM_LEN(im, 1) + len2 = IM_LEN(im, 2) + call imunmap (im) + + switch (ndim) { + case 1: + section[1] = EOS + default: + if (len2 == 1) { + section[1] = EOS + return + } + + if (secstr[1] == '[') + call strcpy (secstr, section, sz_section) + else { + call sscan (secstr) + call gargwrd (wrd1, SZ_WRD) + i = strdic (wrd1, wrd1, SZ_WRD, "|column|line|middle|last|") + call gargwrd (wrd2, SZ_WRD) + j = strdic (wrd2, wrd2, SZ_WRD, "|column|line|middle|last|") + + if ((j == 1) || (j == 2)) { + k = i + i = j + j = k + call strcpy (wrd1, wrd2, SZ_WRD) + } + + switch (i) { + case 1: + switch (j) { + case 3: + call sprintf (section, sz_section, "[%d,*]") + call pargi ((len1 + 1) / 2) + case 4: + call sprintf (section, sz_section, "[%d,*]") + call pargi (len1) + default: + i = 1 + if (ctoi (wrd2, i, len1) == 0) + call error (0, "Bad column number") + call sprintf (section, sz_section, "[%d,*]") + call pargi (len1) + } + case 2: + switch (j) { + case 3: + call sprintf (section, sz_section, "[*,%d]") + call pargi ((len2 + 1) / 2) + case 4: + call sprintf (section, sz_section, "[*,%d]") + call pargi (len2) + default: + i = 1 + if (ctoi (wrd2, i, len1) == 0) + call error (0, "Bad line number") + call sprintf (section, sz_section, "[*,%d]") + call pargi (len1) + } + default: + call error (0, + "Unknown section specification - Possible non-unique abbreviation") + } + } + } +end + + +# XT_MKIMSEC -- Apply a generalized image section to an image. + +procedure xt_mkimsec (image, secstr, imagesec, sz_fname) + +char image[ARB] # Image name +char secstr[ARB] # Image section string +char imagesec[sz_fname] # Image with section +int sz_fname # Maximum size of image name + +char section[SZ_FNAME] +errchk xt_mksection() + +begin + call xt_mksection (image, secstr, section, SZ_FNAME) + call sprintf (imagesec, sz_fname, "%s%s") + call pargstr (image) + call pargstr (section) +end + + +# XT_MK1D -- In some applications a one dimensional image is expected. +# This procedure checks to see if the image is one dimensional. If it is +# not then a section is added to the image name. This procedure should +# not be used and xt_mkimsec should be used instead. + +procedure xt_mk1d (image, secstr, sz_fname) + +char image[sz_fname] # Image name +char secstr[ARB] # Image section string +int sz_fname # Maximum size of image name + +char section[SZ_FNAME] +errchk xt_mksection() + +begin + call xt_mksection (image, secstr, section, SZ_FNAME) + call strcat (section, image, sz_fname) +end diff --git a/pkg/xtools/xtphistory.x b/pkg/xtools/xtphistory.x new file mode 100644 index 00000000..02be88b9 --- /dev/null +++ b/pkg/xtools/xtphistory.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# XT_PHISTORY -- Put history string. + +procedure xt_phistory (im, str) + +pointer im # IMIO pointer +char str # String to be put in history + +pointer sp, timestr + +long clktime() + +begin + call smark (sp) + call salloc (timestr, SZ_LINE, TY_CHAR) + call cnvdate (clktime (0), Memc[timestr], SZ_LINE) + call strcat (Memc[timestr], IM_HISTORY(im), SZ_IMHIST) + call strcat (": ", IM_HISTORY(im), SZ_IMHIST) + call strcat (str, IM_HISTORY(im), SZ_IMHIST) + call sfree (sp) +end diff --git a/pkg/xtools/xtsample.gx b/pkg/xtools/xtsample.gx new file mode 100644 index 00000000..dc4f4173 --- /dev/null +++ b/pkg/xtools/xtsample.gx @@ -0,0 +1,107 @@ +include <imhdr.h> + + +# XT_SAMPLE -- Get sample of pixels. +# +# This routine returns a sample of unmasked pixels from an N-dim image. +# The input is the image pointer, the mask pointer (which may be NULL), +# the array to be filled, the maximum number of sample plixels, and the +# minimum number of lines to sample. The return value is the actual number +# of pixels which will be less than or equal to the specified maximum number. +# +# The intent of this routine is to sample fairly uniformly but efficiently. +# If nlines is zero the total number of pixels, in raster order, is divided +# into uniform steps. But this may end up reading many lines each for a +# few pixels. To be more efficient if nlines is greater than zero then as +# many pixels per line as possible are read to sample at least the requested +# number of lines. + +$for (sird) +int procedure xt_sample$t (im, bpm, sample, nsample, nlines) + +pointer im #I Image pointer +pointer bpm #I Bad pixel pointer +PIXEL sample[nsample] #I Work array +int nsample #I Maximum number of sample pixels +int nlines #I Minimum number of lines to sample +int nreturn #I Number of pixels returned + +long v[IM_MAXDIM], vbuf[IM_MAXDIM] +int i, ip, n, ndim, npix, nc +real p, c, pstep, cstep +pointer buf, bpmbuf + +int imgnls() +$if (datatype != s) +int imgnl$t() +$endif + +begin + # Determine the number of pixels in the data, the number + # to make up nsample pixels, and the pixel step. + + ndim = IM_NDIM(im) + nc = IM_LEN(im,1) + npix = 1 + do i = 1, ndim + npix = npix * IM_LEN(im,i) + pstep = real(npix) / min (npix, nsample) + + # To insure a minimum number of lines and efficient use of + # pixels in a line, set the column step. + + if (nlines == 0) + cstep = pstep + else + cstep = nc / min (min(npix,nsample)/nlines, nc) + + # Step through the pixels. + call amovkl (long(1), v, IM_MAXDIM) + nreturn = 0 + for (p=(pstep-0.01)/2; p<npix && nreturn<nsample;) { + + # Convert pixel number to image vector coordinates. + n = npix; ip = nint(p) + do i = ndim, 1, -1 { + n = n / IM_LEN(im,i) + v[i] = 1 + ip / n + ip = mod (ip, n) + } + + # Sample the pixels in the line. + if (nlines == 0) + c = v[1] + else + c = (cstep - 0.01) / 2 + + if (bpm == NULL) { + v[1] = 1 + if (imgnl$t (im, buf, v) == EOF) + break + for (; c<nc && nreturn<nsample; c=c+cstep) { + ip = nint (c) + nreturn = nreturn + 1 + sample[nreturn] = Mem$t[buf+ip] + p = p + pstep + } + } else { + v[1] = 1 + call amovl (v, vbuf, IM_MAXDIM) + if (imgnls (bpm, bpmbuf, vbuf) == EOF) + break + if (imgnl$t (im, buf, v) == EOF) + break + for (; c<nc && nreturn<nsample; c=c+cstep) { + ip = nint (c) + if (Mems[bpmbuf+ip] == 0) { + nreturn = nreturn + 1 + sample[nreturn] = Mem$t[buf+ip] + } + p = p + pstep + } + } + } + + return (nreturn) +end +$endfor diff --git a/pkg/xtools/xtsample.x b/pkg/xtools/xtsample.x new file mode 100644 index 00000000..e8184e1d --- /dev/null +++ b/pkg/xtools/xtsample.x @@ -0,0 +1,362 @@ +include <imhdr.h> + + +# XT_SAMPLE -- Get sample of pixels. +# +# This routine returns a sample of unmasked pixels from an N-dim image. +# The input is the image pointer, the mask pointer (which may be NULL), +# the array to be filled, the maximum number of sample plixels, and the +# minimum number of lines to sample. The return value is the actual number +# of pixels which will be less than or equal to the specified maximum number. +# +# The intent of this routine is to sample fairly uniformly but efficiently. +# If nlines is zero the total number of pixels, in raster order, is divided +# into uniform steps. But this may end up reading many lines each for a +# few pixels. To be more efficient if nlines is greater than zero then as +# many pixels per line as possible are read to sample at least the requested +# number of lines. + + +int procedure xt_samples (im, bpm, sample, nsample, nlines) + +pointer im #I Image pointer +pointer bpm #I Bad pixel pointer +short sample[nsample] #I Work array +int nsample #I Maximum number of sample pixels +int nlines #I Minimum number of lines to sample +int nreturn #I Number of pixels returned + +long v[IM_MAXDIM], vbuf[IM_MAXDIM] +int i, ip, n, ndim, npix, nc +real p, c, pstep, cstep +pointer buf, bpmbuf + +int imgnls() + +begin + # Determine the number of pixels in the data, the number + # to make up nsample pixels, and the pixel step. + + ndim = IM_NDIM(im) + nc = IM_LEN(im,1) + npix = 1 + do i = 1, ndim + npix = npix * IM_LEN(im,i) + pstep = real(npix) / min (npix, nsample) + + # To insure a minimum number of lines and efficient use of + # pixels in a line, set the column step. + + if (nlines == 0) + cstep = pstep + else + cstep = nc / min (min(npix,nsample)/nlines, nc) + + # Step through the pixels. + call amovkl (long(1), v, IM_MAXDIM) + nreturn = 0 + for (p=(pstep-0.01)/2; p<npix && nreturn<nsample;) { + + # Convert pixel number to image vector coordinates. + n = npix; ip = nint(p) + do i = ndim, 1, -1 { + n = n / IM_LEN(im,i) + v[i] = 1 + ip / n + ip = mod (ip, n) + } + + # Sample the pixels in the line. + if (nlines == 0) + c = v[1] + else + c = (cstep - 0.01) / 2 + + if (bpm == NULL) { + v[1] = 1 + if (imgnls (im, buf, v) == EOF) + break + for (; c<nc && nreturn<nsample; c=c+cstep) { + ip = nint (c) + nreturn = nreturn + 1 + sample[nreturn] = Mems[buf+ip] + p = p + pstep + } + } else { + v[1] = 1 + call amovl (v, vbuf, IM_MAXDIM) + if (imgnls (bpm, bpmbuf, vbuf) == EOF) + break + if (imgnls (im, buf, v) == EOF) + break + for (; c<nc && nreturn<nsample; c=c+cstep) { + ip = nint (c) + if (Mems[bpmbuf+ip] == 0) { + nreturn = nreturn + 1 + sample[nreturn] = Mems[buf+ip] + } + p = p + pstep + } + } + } + + return (nreturn) +end + +int procedure xt_samplei (im, bpm, sample, nsample, nlines) + +pointer im #I Image pointer +pointer bpm #I Bad pixel pointer +int sample[nsample] #I Work array +int nsample #I Maximum number of sample pixels +int nlines #I Minimum number of lines to sample +int nreturn #I Number of pixels returned + +long v[IM_MAXDIM], vbuf[IM_MAXDIM] +int i, ip, n, ndim, npix, nc +real p, c, pstep, cstep +pointer buf, bpmbuf + +int imgnls() +int imgnli() + +begin + # Determine the number of pixels in the data, the number + # to make up nsample pixels, and the pixel step. + + ndim = IM_NDIM(im) + nc = IM_LEN(im,1) + npix = 1 + do i = 1, ndim + npix = npix * IM_LEN(im,i) + pstep = real(npix) / min (npix, nsample) + + # To insure a minimum number of lines and efficient use of + # pixels in a line, set the column step. + + if (nlines == 0) + cstep = pstep + else + cstep = nc / min (min(npix,nsample)/nlines, nc) + + # Step through the pixels. + call amovkl (long(1), v, IM_MAXDIM) + nreturn = 0 + for (p=(pstep-0.01)/2; p<npix && nreturn<nsample;) { + + # Convert pixel number to image vector coordinates. + n = npix; ip = nint(p) + do i = ndim, 1, -1 { + n = n / IM_LEN(im,i) + v[i] = 1 + ip / n + ip = mod (ip, n) + } + + # Sample the pixels in the line. + if (nlines == 0) + c = v[1] + else + c = (cstep - 0.01) / 2 + + if (bpm == NULL) { + v[1] = 1 + if (imgnli (im, buf, v) == EOF) + break + for (; c<nc && nreturn<nsample; c=c+cstep) { + ip = nint (c) + nreturn = nreturn + 1 + sample[nreturn] = Memi[buf+ip] + p = p + pstep + } + } else { + v[1] = 1 + call amovl (v, vbuf, IM_MAXDIM) + if (imgnls (bpm, bpmbuf, vbuf) == EOF) + break + if (imgnli (im, buf, v) == EOF) + break + for (; c<nc && nreturn<nsample; c=c+cstep) { + ip = nint (c) + if (Mems[bpmbuf+ip] == 0) { + nreturn = nreturn + 1 + sample[nreturn] = Memi[buf+ip] + } + p = p + pstep + } + } + } + + return (nreturn) +end + +int procedure xt_sampler (im, bpm, sample, nsample, nlines) + +pointer im #I Image pointer +pointer bpm #I Bad pixel pointer +real sample[nsample] #I Work array +int nsample #I Maximum number of sample pixels +int nlines #I Minimum number of lines to sample +int nreturn #I Number of pixels returned + +long v[IM_MAXDIM], vbuf[IM_MAXDIM] +int i, ip, n, ndim, npix, nc +real p, c, pstep, cstep +pointer buf, bpmbuf + +int imgnls() +int imgnlr() + +begin + # Determine the number of pixels in the data, the number + # to make up nsample pixels, and the pixel step. + + ndim = IM_NDIM(im) + nc = IM_LEN(im,1) + npix = 1 + do i = 1, ndim + npix = npix * IM_LEN(im,i) + pstep = real(npix) / min (npix, nsample) + + # To insure a minimum number of lines and efficient use of + # pixels in a line, set the column step. + + if (nlines == 0) + cstep = pstep + else + cstep = nc / min (min(npix,nsample)/nlines, nc) + + # Step through the pixels. + call amovkl (long(1), v, IM_MAXDIM) + nreturn = 0 + for (p=(pstep-0.01)/2; p<npix && nreturn<nsample;) { + + # Convert pixel number to image vector coordinates. + n = npix; ip = nint(p) + do i = ndim, 1, -1 { + n = n / IM_LEN(im,i) + v[i] = 1 + ip / n + ip = mod (ip, n) + } + + # Sample the pixels in the line. + if (nlines == 0) + c = v[1] + else + c = (cstep - 0.01) / 2 + + if (bpm == NULL) { + v[1] = 1 + if (imgnlr (im, buf, v) == EOF) + break + for (; c<nc && nreturn<nsample; c=c+cstep) { + ip = nint (c) + nreturn = nreturn + 1 + sample[nreturn] = Memr[buf+ip] + p = p + pstep + } + } else { + v[1] = 1 + call amovl (v, vbuf, IM_MAXDIM) + if (imgnls (bpm, bpmbuf, vbuf) == EOF) + break + if (imgnlr (im, buf, v) == EOF) + break + for (; c<nc && nreturn<nsample; c=c+cstep) { + ip = nint (c) + if (Mems[bpmbuf+ip] == 0) { + nreturn = nreturn + 1 + sample[nreturn] = Memr[buf+ip] + } + p = p + pstep + } + } + } + + return (nreturn) +end + +int procedure xt_sampled (im, bpm, sample, nsample, nlines) + +pointer im #I Image pointer +pointer bpm #I Bad pixel pointer +double sample[nsample] #I Work array +int nsample #I Maximum number of sample pixels +int nlines #I Minimum number of lines to sample +int nreturn #I Number of pixels returned + +long v[IM_MAXDIM], vbuf[IM_MAXDIM] +int i, ip, n, ndim, npix, nc +real p, c, pstep, cstep +pointer buf, bpmbuf + +int imgnls() +int imgnld() + +begin + # Determine the number of pixels in the data, the number + # to make up nsample pixels, and the pixel step. + + ndim = IM_NDIM(im) + nc = IM_LEN(im,1) + npix = 1 + do i = 1, ndim + npix = npix * IM_LEN(im,i) + pstep = real(npix) / min (npix, nsample) + + # To insure a minimum number of lines and efficient use of + # pixels in a line, set the column step. + + if (nlines == 0) + cstep = pstep + else + cstep = nc / min (min(npix,nsample)/nlines, nc) + + # Step through the pixels. + call amovkl (long(1), v, IM_MAXDIM) + nreturn = 0 + for (p=(pstep-0.01)/2; p<npix && nreturn<nsample;) { + + # Convert pixel number to image vector coordinates. + n = npix; ip = nint(p) + do i = ndim, 1, -1 { + n = n / IM_LEN(im,i) + v[i] = 1 + ip / n + ip = mod (ip, n) + } + + # Sample the pixels in the line. + if (nlines == 0) + c = v[1] + else + c = (cstep - 0.01) / 2 + + if (bpm == NULL) { + v[1] = 1 + if (imgnld (im, buf, v) == EOF) + break + for (; c<nc && nreturn<nsample; c=c+cstep) { + ip = nint (c) + nreturn = nreturn + 1 + sample[nreturn] = Memd[buf+ip] + p = p + pstep + } + } else { + v[1] = 1 + call amovl (v, vbuf, IM_MAXDIM) + if (imgnls (bpm, bpmbuf, vbuf) == EOF) + break + if (imgnld (im, buf, v) == EOF) + break + for (; c<nc && nreturn<nsample; c=c+cstep) { + ip = nint (c) + if (Mems[bpmbuf+ip] == 0) { + nreturn = nreturn + 1 + sample[nreturn] = Memd[buf+ip] + } + p = p + pstep + } + } + } + + return (nreturn) +end + diff --git a/pkg/xtools/xtsort.x b/pkg/xtools/xtsort.x new file mode 100644 index 00000000..9d3535e8 --- /dev/null +++ b/pkg/xtools/xtsort.x @@ -0,0 +1,216 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# XT_SORT2 -- Sort 2 dimensional vectors by the first component. + +procedure xt_sort2 (a1, a2, npts) + +real a1[npts], a2[npts] # Arrays to be sorted +int npts # Number of points + +int i, j +pointer sp, index, ptr + +int xts_compare() +extern xts_compare + +begin + call smark (sp) + call salloc (index, npts, TY_INT) + call salloc (ptr, npts, TY_REAL) + + do i = 1, npts + Memi[index+i-1] = ptr + i - 1 + + call amovr (a1, Memr[ptr], npts) + + call qsort (Memi[index], npts, xts_compare) + + do i = 1, npts { + j = Memi[index+i-1] + a1[i] = Memr[j] + } + + call amovr (a2, Memr[ptr], npts) + do i = 1, npts { + j = Memi[index+i-1] + a2[i] = Memr[j] + } + + call sfree (sp) +end + + +# XT_SORT3 -- Sort 3 dimensional vectors by the first component. + +procedure xt_sort3 (a1, a2, a3, npts) + +real a1[npts], a2[npts], a3[npts] # Arrays to be sorted +int npts # Number of points + +int i, j +pointer sp, index, ptr + +int xts_compare() +extern xts_compare + +begin + call smark (sp) + call salloc (index, npts, TY_INT) + call salloc (ptr, npts, TY_REAL) + + do i = 1, npts + Memi[index+i-1] = ptr + i - 1 + + call amovr (a1, Memr[ptr], npts) + + call qsort (Memi[index], npts, xts_compare) + + do i = 1, npts { + j = Memi[index+i-1] + a1[i] = Memr[j] + } + + call amovr (a2, Memr[ptr], npts) + do i = 1, npts { + j = Memi[index+i-1] + a2[i] = Memr[j] + } + + call amovr (a3, Memr[ptr], npts) + do i = 1, npts { + j = Memi[index+i-1] + a3[i] = Memr[j] + } + + call sfree (sp) +end + + +# XT_SORT4 -- Sort 4 dimensional vectors by the first component. + +procedure xt_sort4 (a1, a2, a3, a4, npts) + +real a1[npts], a2[npts], a3[npts], a4[npts] # Arrays to be sorted +int npts # Number of points + +int i, j +pointer sp, index, ptr + +int xts_compare() +extern xts_compare + +begin + call smark (sp) + call salloc (index, npts, TY_INT) + call salloc (ptr, npts, TY_REAL) + + do i = 1, npts + Memi[index+i-1] = ptr + i - 1 + + call amovr (a1, Memr[ptr], npts) + + call qsort (Memi[index], npts, xts_compare) + + do i = 1, npts { + j = Memi[index+i-1] + a1[i] = Memr[j] + } + + call amovr (a2, Memr[ptr], npts) + do i = 1, npts { + j = Memi[index+i-1] + a2[i] = Memr[j] + } + + call amovr (a3, Memr[ptr], npts) + do i = 1, npts { + j = Memi[index+i-1] + a3[i] = Memr[j] + } + + call amovr (a4, Memr[ptr], npts) + do i = 1, npts { + j = Memi[index+i-1] + a4[i] = Memr[j] + } + + call sfree (sp) +end + + +# XTS_COMPARE -- Compare two real values in the Memr array. + +int procedure xts_compare (i, j) + +pointer i, j # Array indices to be compared. + +begin + if (Memr[i] < Memr[j]) + return (-1) + else if (Memr[i] > Memr[j]) + return (1) + else + return (0) +end + + +# XT_SORT3D -- Sort 3 double precision vectors by the first component. + +procedure xt_sort3d (a1, a2, a3, npts) + +double a1[npts], a2[npts], a3[npts] # Arrays to be sorted +int npts # Number of points + +int i, j +pointer sp, index, ptr + +int xts_compared() +extern xts_compared + +begin + call smark (sp) + call salloc (index, npts, TY_INT) + call salloc (ptr, npts, TY_DOUBLE) + + do i = 1, npts + Memi[index+i-1] = ptr + i - 1 + + call amovd (a1, Memd[ptr], npts) + + call qsort (Memi[index], npts, xts_compared) + + do i = 1, npts { + j = Memi[index+i-1] + a1[i] = Memd[j] + } + + call amovd (a2, Memd[ptr], npts) + do i = 1, npts { + j = Memi[index+i-1] + a2[i] = Memd[j] + } + + call amovd (a3, Memd[ptr], npts) + do i = 1, npts { + j = Memi[index+i-1] + a3[i] = Memd[j] + } + + call sfree (sp) +end + + +# XTS_COMPARED -- Compare two double values in the Memd array. + +int procedure xts_compared (i, j) + +pointer i, j # Array indices to be compared. + +begin + if (Memd[i] < Memd[j]) + return (-1) + else if (Memd[i] > Memd[j]) + return (1) + else + return (0) +end diff --git a/pkg/xtools/xtstat.gx b/pkg/xtools/xtstat.gx new file mode 100644 index 00000000..99012f71 --- /dev/null +++ b/pkg/xtools/xtstat.gx @@ -0,0 +1,107 @@ +# XT_STAT -- Compute statistics from a sample. +# +# The sample array will be sorted. + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + +$for (sird) +procedure xt_stat$t (sample, nsample, frac, mean, sigma, median, mode) + +PIXEL sample[nsample] #I Sample +int nsample #I Number of sample pixels +real frac #I Fraction of data to use +$if (datatype == d) +double mean, sigma, median, mode #O Statistics +$else +real mean, sigma, median, mode #O Statistics +$endif + +int i, j, k, nmax +$if (datatype == d) +double z1, z2, zstep, zbin +bool fp_equald() +$else +real z1, z2, zstep, zbin +bool fp_equalr() +$endif + +begin + # Sort the sample. + call asrt$t (sample, sample, nsample) + + # Set fraction to use. + i = max (1, 1 + nsample * (1. - frac) / 2.) + j = min (nsample, 1 + nsample * (1. + frac) / 2.) + z1 = sample[i] + z2 = sample[j] + + # Compute the mean and sigma. + call aavg$t (sample[i], j-i+1, mean, sigma) + + # Compute the median. + median = sample[nsample/2] + + z1 = median - 2 * sigma + if (z1 < sample[1]) + i = 1 + else { + k = i + do i = k, 2, -1 { + if (sample[i] <= z1) + break + } + } + z1 = sample[i] + + z2 = median + 2 * sigma + if (z2 > sample[nsample]) + i = nsample + else { + k = j + do j = k, nsample-1 { + if (sample[j] >= z1) + break + } + } + z2 = sample[j] + + # Compute the mode. + + if (nsample < NMIN) + mode = median + +$if (datatype == d) + else if (fp_equald (z1, z2)) +$else + else if (fp_equalr (z1, z2)) +$endif + mode = z1 + + else { + zstep = ZSTEP * sigma + zbin = ZBIN * sigma + $if (datatype == sil) + zstep = max (1., zstep) + zbin = max (1., zbin) + $endif + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && sample[i] < z1; i=i+1) + ; + for (; k < j && sample[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = sample[(i+k)/2] + } + } until (k >= j) + } +end +$endfor diff --git a/pkg/xtools/xtstat.x b/pkg/xtools/xtstat.x new file mode 100644 index 00000000..1979fddf --- /dev/null +++ b/pkg/xtools/xtstat.x @@ -0,0 +1,337 @@ +# XT_STAT -- Compute statistics from a sample. +# +# The sample array will be sorted. + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + + +procedure xt_stats (sample, nsample, frac, mean, sigma, median, mode) + +short sample[nsample] #I Sample +int nsample #I Number of sample pixels +real frac #I Fraction of data to use +real mean, sigma, median, mode #O Statistics + +int i, j, k, nmax +real z1, z2, zstep, zbin +bool fp_equalr() + +begin + # Sort the sample. + call asrts (sample, sample, nsample) + + # Set fraction to use. + i = max (1, 1 + nsample * (1. - frac) / 2.) + j = min (nsample, 1 + nsample * (1. + frac) / 2.) + z1 = sample[i] + z2 = sample[j] + + # Compute the mean and sigma. + call aavgs (sample[i], j-i+1, mean, sigma) + + # Compute the median. + median = sample[nsample/2] + + z1 = median - 2 * sigma + if (z1 < sample[1]) + i = 1 + else { + k = i + do i = k, 2, -1 { + if (sample[i] <= z1) + break + } + } + z1 = sample[i] + + z2 = median + 2 * sigma + if (z2 > sample[nsample]) + i = nsample + else { + k = j + do j = k, nsample-1 { + if (sample[j] >= z1) + break + } + } + z2 = sample[j] + + # Compute the mode. + + if (nsample < NMIN) + mode = median + + else if (fp_equalr (z1, z2)) + mode = z1 + + else { + zstep = ZSTEP * sigma + zbin = ZBIN * sigma + zstep = max (1., zstep) + zbin = max (1., zbin) + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && sample[i] < z1; i=i+1) + ; + for (; k < j && sample[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = sample[(i+k)/2] + } + } until (k >= j) + } +end + +procedure xt_stati (sample, nsample, frac, mean, sigma, median, mode) + +int sample[nsample] #I Sample +int nsample #I Number of sample pixels +real frac #I Fraction of data to use +real mean, sigma, median, mode #O Statistics + +int i, j, k, nmax +real z1, z2, zstep, zbin +bool fp_equalr() + +begin + # Sort the sample. + call asrti (sample, sample, nsample) + + # Set fraction to use. + i = max (1, 1 + nsample * (1. - frac) / 2.) + j = min (nsample, 1 + nsample * (1. + frac) / 2.) + z1 = sample[i] + z2 = sample[j] + + # Compute the mean and sigma. + call aavgi (sample[i], j-i+1, mean, sigma) + + # Compute the median. + median = sample[nsample/2] + + z1 = median - 2 * sigma + if (z1 < sample[1]) + i = 1 + else { + k = i + do i = k, 2, -1 { + if (sample[i] <= z1) + break + } + } + z1 = sample[i] + + z2 = median + 2 * sigma + if (z2 > sample[nsample]) + i = nsample + else { + k = j + do j = k, nsample-1 { + if (sample[j] >= z1) + break + } + } + z2 = sample[j] + + # Compute the mode. + + if (nsample < NMIN) + mode = median + + else if (fp_equalr (z1, z2)) + mode = z1 + + else { + zstep = ZSTEP * sigma + zbin = ZBIN * sigma + zstep = max (1., zstep) + zbin = max (1., zbin) + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && sample[i] < z1; i=i+1) + ; + for (; k < j && sample[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = sample[(i+k)/2] + } + } until (k >= j) + } +end + +procedure xt_statr (sample, nsample, frac, mean, sigma, median, mode) + +real sample[nsample] #I Sample +int nsample #I Number of sample pixels +real frac #I Fraction of data to use +real mean, sigma, median, mode #O Statistics + +int i, j, k, nmax +real z1, z2, zstep, zbin +bool fp_equalr() + +begin + # Sort the sample. + call asrtr (sample, sample, nsample) + + # Set fraction to use. + i = max (1, 1 + nsample * (1. - frac) / 2.) + j = min (nsample, 1 + nsample * (1. + frac) / 2.) + z1 = sample[i] + z2 = sample[j] + + # Compute the mean and sigma. + call aavgr (sample[i], j-i+1, mean, sigma) + + # Compute the median. + median = sample[nsample/2] + + z1 = median - 2 * sigma + if (z1 < sample[1]) + i = 1 + else { + k = i + do i = k, 2, -1 { + if (sample[i] <= z1) + break + } + } + z1 = sample[i] + + z2 = median + 2 * sigma + if (z2 > sample[nsample]) + i = nsample + else { + k = j + do j = k, nsample-1 { + if (sample[j] >= z1) + break + } + } + z2 = sample[j] + + # Compute the mode. + + if (nsample < NMIN) + mode = median + + else if (fp_equalr (z1, z2)) + mode = z1 + + else { + zstep = ZSTEP * sigma + zbin = ZBIN * sigma + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && sample[i] < z1; i=i+1) + ; + for (; k < j && sample[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = sample[(i+k)/2] + } + } until (k >= j) + } +end + +procedure xt_statd (sample, nsample, frac, mean, sigma, median, mode) + +double sample[nsample] #I Sample +int nsample #I Number of sample pixels +real frac #I Fraction of data to use +double mean, sigma, median, mode #O Statistics + +int i, j, k, nmax +double z1, z2, zstep, zbin +bool fp_equald() + +begin + # Sort the sample. + call asrtd (sample, sample, nsample) + + # Set fraction to use. + i = max (1, 1 + nsample * (1. - frac) / 2.) + j = min (nsample, 1 + nsample * (1. + frac) / 2.) + z1 = sample[i] + z2 = sample[j] + + # Compute the mean and sigma. + call aavgd (sample[i], j-i+1, mean, sigma) + + # Compute the median. + median = sample[nsample/2] + + z1 = median - 2 * sigma + if (z1 < sample[1]) + i = 1 + else { + k = i + do i = k, 2, -1 { + if (sample[i] <= z1) + break + } + } + z1 = sample[i] + + z2 = median + 2 * sigma + if (z2 > sample[nsample]) + i = nsample + else { + k = j + do j = k, nsample-1 { + if (sample[j] >= z1) + break + } + } + z2 = sample[j] + + # Compute the mode. + + if (nsample < NMIN) + mode = median + + else if (fp_equald (z1, z2)) + mode = z1 + + else { + zstep = ZSTEP * sigma + zbin = ZBIN * sigma + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && sample[i] < z1; i=i+1) + ; + for (; k < j && sample[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = sample[(i+k)/2] + } + } until (k >= j) + } +end + diff --git a/pkg/xtools/xtstripwhite.x b/pkg/xtools/xtstripwhite.x new file mode 100644 index 00000000..b6cf09c3 --- /dev/null +++ b/pkg/xtools/xtstripwhite.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> + +# XT_STRIPWHITE -- Strip leading white space from a string. +# The string must have an EOS. + +procedure xt_stripwhite (str) + +char str[ARB] # String to be stripped + +int i + +begin + for (i=1; (str[i]!=EOS) && (IS_WHITE(str[i])); i=i+1) + ; + call strcpy (str[i], str, ARB) +end diff --git a/pkg/xtools/xtsums.x b/pkg/xtools/xtsums.x new file mode 100644 index 00000000..8d6172f8 --- /dev/null +++ b/pkg/xtools/xtsums.x @@ -0,0 +1,394 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# XT_LSUM -- Sum lines +# +# A new sum vector is created when the data pointer is null or if the number +# of columns is changed. If the previous sum overlaps the requested sum then +# additions and subtractions are performed on the previous sum to minimize +# the number of arithmetic operations. + +procedure xt_lsum (im, col1, col2, line1, line2, data) + +pointer im # IMIO pointer +int col1, col2 # Column limits of the sum +int line1, line2 # Line limits +pointer data # Data pointer + +int i +int ncols, nlines, nc, nl, c1, c2, l1, l2 +pointer j + +pointer imgs2r() + +begin + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + if ((data == NULL) || (ncols != nc)) { + call mfree (data, TY_REAL) + call malloc (data, ncols, TY_REAL) + nc = ncols + l1 = 0 + l2 = 0 + } + + if (nlines != nl) { + nl = nlines + l1 = 0 + l2 = 0 + } + + # If only one line then don't bother with summing. + + if (nlines == 1) { + if ((line1 != l1) || (col1 != c1) || (col2 != c2)) { + c1 = col1 + c2 = col2 + l1 = line1 + l2 = line2 + j = imgs2r (im, c1, c2, l1, l2) + call amovr (Memr[j], Memr[data], nc) + } + return + } + + # If the sum limits are outside the last sum limits then form + # the sums from scratch. + + if ((line1 > l2) || (line2 < l1) || (col1 != c1) || (col2 != c2)) { + c1 = col1 + c2 = col2 + l1 = line1 + l2 = line2 + call aclrr (Memr[data], nc) + do i = l1, l2 { + j = imgs2r (im, c1, c2, i, i) + call aaddr (Memr[data], Memr[j], Memr[data], nc) + } + + # If the sum limits overlap then add and subtract to compute the + # new sums from the previous sums. This minimizes the number of + # arithmetic operations in common applications. + + } else if (line1 > l1) { + do i = l1, line1 - 1 { + j = imgs2r (im, c1, c2, i, i) + call asubr (Memr[data], Memr[j], Memr[data], nc) + } + do i = l2 + 1, line2 { + j = imgs2r (im, c1, c2, i, i) + call aaddr (Memr[data], Memr[j], Memr[data], nc) + } + l1 = line1 + l2 = line2 + + } else { + do i = line2 + 1, l2 { + j = imgs2r (im, c1, c2, i, i) + call asubr (Memr[data], Memr[j], Memr[data], nc) + } + do i = line1, l1 - 1 { + j = imgs2r (im, c1, c2, i, i) + call aaddr (Memr[data], Memr[j], Memr[data], nc) + } + l1 = line1 + l2 = line2 + } +end + + +# XT_CSUM -- Sum columns +# +# A new sum vector is created when the data pointer is null or if the number +# of lines is changed. If the previous sum overlaps the requested sum then +# additions and subtractions are performed on the previous sum to minimize +# the number of arithmetic operations. + +procedure xt_csum (co, col1, col2, line1, line2, data) + +pointer co # COIO pointer +int col1, col2 # Column limits of the sum +int line1, line2 # Line limits +pointer data # Data pointer + +int i +int ncols, nlines, nc, nl, c1, c2, l1, l2 +pointer j + +pointer cogetr() + +begin + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + if ((data == NULL) || (nlines != nl)) { + call mfree (data, TY_REAL) + call malloc (data, nlines, TY_REAL) + nl = nlines + c1 = 0 + c2 = 0 + } + + if (ncols != nc) { + nc = ncols + c1 = 0 + c2 = 0 + } + + # If only one column then don't bother with summing. + + if (ncols == 1) { + if ((col1 != c1) || (line1 != l1) || (line2 != l2)) { + c1 = col1 + c2 = col2 + l1 = line1 + l2 = line2 + j = cogetr (co, c1, l1, l2) + call amovr (Memr[j], Memr[data], nl) + } + return + } + + # If the sum limits are outside the last sum limits then form + # the sums from scratch. + + if ((col1 > c2) || (col2 < c1) || (line1 != l1) || (line2 != l2)) { + c1 = col1 + c2 = col2 + l1 = line1 + l2 = line2 + call aclrr (Memr[data], nlines) + do i = c1, c2 { + j = cogetr (co, i, l1, l2) + call aaddr (Memr[data], Memr[j], Memr[data], nl) + } + + # If the sum limits overlap then add and subtract to compute the + # new sums from the previous sums. This minimizes the number of + # arithmetic operations in common applications. + + } else if (col1 > c1) { + do i = c1, col1 - 1 { + j = cogetr (co, i, l1, l2) + call asubr (Memr[data], Memr[j], Memr[data], nl) + } + do i = c2 + 1, col2 { + j = cogetr (co, i, l1, l2) + call aaddr (Memr[data], Memr[j], Memr[data], nl) + } + c1 = col1 + c2 = col2 + + } else { + do i = col2 + 1, c2 { + j = cogetr (co, i, l1, l2) + call asubr (Memr[data], Memr[j], Memr[data], nl) + } + do i = col1, c1 - 1 { + j = cogetr (co, i, l1, l2) + call aaddr (Memr[data], Memr[j], Memr[data], nl) + } + c1 = col1 + c2 = col2 + } +end + + +# XT_LSUMB -- Sum lines with buffering +# +# A new sum vector is created when the data pointer is null or if the number +# of columns is changed. If the previous sum overlaps the requested sum then +# additions and subtractions are performed on the previous sum to minimize +# the number of arithmetic operations. Buffering of previous lines is done. + +procedure xt_lsumb (im, col1, col2, line1, line2, data) + +pointer im # IMIO pointer +int col1, col2 # Column limits of the sum +int line1, line2 # Line limits +pointer data # Data pointer + +int i +int ncols, nlines, nc, nl, c1, c2, l1, l2 +pointer j + +pointer imgs2r() + +begin + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + if ((data == NULL) || (ncols != nc)) { + call mfree (data, TY_REAL) + call malloc (data, (nlines + 1) * ncols, TY_REAL) + nc = ncols + l1 = 0 + l2 = 0 + } + + if (nlines != nl) { + nl = nlines + l1 = 0 + l2 = 0 + } + + # If only one line then don't bother with summing. + + if (nlines == 1) { + if ((line1 != l1) || (col1 != c1) || (col2 != c2)) { + c1 = col1 + c2 = col2 + l1 = line1 + l2 = line2 + j = imgs2r (im, c1, c2, l1, l2) + call amovr (Memr[j], Memr[data], nc) + } + return + } + + # If the sum limits are outside the last sum limits then form + # the sums from scratch. + + if ((line1 > l2) || (line2 < l1) || (col1 != c1) || (col2 != c2)) { + c1 = col1 + c2 = col2 + l1 = line1 + l2 = line2 + call aclrr (Memr[data], nc) + do i = l1, l2 { + j = data + (mod (i, nl) + 1) * nc + call amovr (Memr[imgs2r (im, c1, c2, i, i)], Memr[j], nc) + call aaddr (Memr[data], Memr[j], Memr[data], nc) + } + + # If the sum limits overlap then add and subtract to compute the + # new sums from the previous sums. This minimizes the number of + # arithmetic operations in common applications. + + } else if (line1 > l1) { + do i = l1, line1 - 1 { + j = data + (mod (i, nl) + 1) * nc + call asubr (Memr[data], Memr[j], Memr[data], nc) + } + do i = l2 + 1, line2 { + j = data + (mod (i, nl) + 1) * nc + call amovr (Memr[imgs2r (im, c1, c2, i, i)], Memr[j], nc) + call aaddr (Memr[data], Memr[j], Memr[data], nc) + } + l1 = line1 + l2 = line2 + + } else { + do i = line2 + 1, l2 { + j = data + (mod (i, nl) + 1) * nc + call asubr (Memr[data], Memr[j], Memr[data], nc) + } + do i = line1, l1 - 1 { + j = data + (mod (i, nl) + 1) * nc + call amovr (Memr[imgs2r (im, c1, c2, i, i)], Memr[j], nc) + call aaddr (Memr[data], Memr[j], Memr[data], nc) + } + l1 = line1 + l2 = line2 + } +end + + +# XT_CSUMB -- Sum columns with buffering +# +# A new sum vector is created when the data pointer is null or if the number +# of lines is changed. If the previous sum overlaps the requested sum then +# additions and subtractions are performed on the previous sum to minimize +# the number of arithmetic operations. Buffering is done on the previous cols. + +procedure xt_csumb (co, col1, col2, line1, line2, data) + +pointer co # COIO pointer +int col1, col2 # Column limits of the sum +int line1, line2 # Line limits +pointer data # Data pointer + +int i +int ncols, nlines, nc, nl, c1, c2, l1, l2 +pointer j + +pointer cogetr() + +begin + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + if ((data == NULL) || (nlines != nl)) { + call mfree (data, TY_REAL) + call malloc (data, (ncols + 1) * nlines, TY_REAL) + nl = nlines + c1 = 0 + c2 = 0 + } + + if (ncols != nc) { + nc = ncols + c1 = 0 + c2 = 0 + } + + # If only one column then don't bother with summing. + + if (ncols == 1) { + if ((col1 != c1) || (line1 != l1) || (line2 != l2)) { + c1 = col1 + c2 = col2 + l1 = line1 + l2 = line2 + j = cogetr (co, c1, l1, l2) + call amovr (Memr[j], Memr[data], nl) + } + return + } + + # If the sum limits are outside the last sum limits then form + # the sums from scratch. + + if ((col1 > c2) || (col2 < c1) || (line1 != l1) || (line2 != l2)) { + c1 = col1 + c2 = col2 + l1 = line1 + l2 = line2 + call aclrr (Memr[data], nlines) + do i = c1, c2 { + j = data + (mod (i, nc) + 1) * nl + call amovr (Memr[cogetr (co, i, l1, l2)], Memr[j], nl) + call aaddr (Memr[data], Memr[j], Memr[data], nl) + } + + # If the sum limits overlap then add and subtract to compute the + # new sums from the previous sums. This minimizes the number of + # arithmetic operations in common applications. + + } else if (col1 > c1) { + do i = c1, col1 - 1 { + j = data + (mod (i, nc) + 1) * nl + call asubr (Memr[data], Memr[j], Memr[data], nl) + } + do i = c2 + 1, col2 { + j = data + (mod (i, nc) + 1) * nl + call amovr (Memr[cogetr (co, i, l1, l2)], Memr[j], nl) + call aaddr (Memr[data], Memr[j], Memr[data], nl) + } + c1 = col1 + c2 = col2 + + } else { + do i = col2 + 1, c2 { + j = data + (mod (i, nc) + 1) * nl + call asubr (Memr[data], Memr[j], Memr[data], nl) + } + do i = col1, c1 - 1 { + j = data + (mod (i, nc) + 1) * nl + call amovr (Memr[cogetr (co, i, l1, l2)], Memr[j], nl) + call aaddr (Memr[data], Memr[j], Memr[data], nl) + } + c1 = col1 + c2 = col2 + } +end diff --git a/pkg/xtools/xttxtfio.x b/pkg/xtools/xttxtfio.x new file mode 100644 index 00000000..88296670 --- /dev/null +++ b/pkg/xtools/xttxtfio.x @@ -0,0 +1,71 @@ +define TXT_MAXFD 64 # Maximum FD for stropen. + + +# XT_TXTOPEN -- Open a READ_ONLY text file which is possibly compiled into a +# procedure. +# +# This is used to allow text files to be incorported in binaries but still use +# FIO. The text file must be compiled into a program which is linked with +# into the binary (see txtcompile). A file name of the form proc:nnnn, where +# nnnn is a number returned by locpr, calls the procedure which is expected to +# allocate a string buffer. In this case the string buffer is opened with +# stropen. Any other file name is opened as a READ_ONLY TEXT_FILE with +# normal FIO. + +int procedure xt_txtopen (fname) + +char fname[ARB] #I File name or proc:nnnn reference +int fd #R Null to open and non-null to close + +int ip, procptr, strncmp(), ctoi(), open(), stropen() +pointer strbuf +errchk zcall1, open, stropen + +int firsttime +data firsttime/YES/ + +pointer buf[TXT_MAXFD] +common /xttxtn_com/ buf + +begin + # Make sure array of string buffer pointers is initialized. + if (firsttime==YES) { + call aclri (buf, TXT_MAXFD) + firsttime = NO + } + + # Determine type of open to use. + if (strncmp (fname, "proc:", 5) == 0) { + ip = 1 + if (ctoi (fname[6], ip, procptr) == 0) + call error (1, "xt_txtopen: bad file specification") + call zcall1 (procptr, strbuf) + fd = stropen (Memc[strbuf], ARB, READ_ONLY) + if (fd > TXT_MAXFD) { + call close (fd) + call mfree (strbuf, TY_CHAR) + call error (1, "xt_txtopen: Too many file descriptors") + } + buf[fd] = strbuf + } else + fd = open (fname, READ_ONLY, TEXT_FILE) + + return (fd) +end + + +# XT_TXTCLOSE -- Close procedure. + +procedure xt_txtclose (fd) + +int fd #O Null to open and non-null to close + +pointer buf[TXT_MAXFD] +common /xttxtn_com/ buf + +begin + # Close file descriptor. + call close (fd); fd = NULL + if (fd <= TXT_MAXFD) + call mfree (buf[fd], TY_CHAR) +end diff --git a/pkg/xtools/zzdebug.x b/pkg/xtools/zzdebug.x new file mode 100644 index 00000000..b8ba551e --- /dev/null +++ b/pkg/xtools/zzdebug.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task ranges = t_ranges + +define MAX_RANGES 101 # Maximum number of range parameters + + +# T_RANGES -- Test the range expression expansion package. + +procedure t_ranges () + +char range_string[SZ_LINE] # Range string +int number # Test integer number + +int ranges[3, MAX_RANGES] +int nvalues, next_number +int decode_ranges(), get_next_number(), get_previous_number() +bool is_in_range() +int clglpi() + +begin + # Get program parameters + call clgstr ("range_string", range_string, SZ_LINE) + + # Decode the range string + if (decode_ranges (range_string, ranges, MAX_RANGES, nvalues) == ERR) + call error (1, "Error parsing range string") + call printf ("Number of values = %d\n") + call pargi (nvalues) + + # Test is_in_range + while (clglpi ("number", number) != EOF) { + if (is_in_range (ranges, number)) { + call printf ("%d is in range\n") + call pargi (number) + } else { + call printf ("%d is not in range\n") + call pargi (number) + } + next_number = number + if (get_next_number (ranges, next_number) != EOF) { + call printf ("Next number is %d\n") + call pargi (next_number) + } + next_number = number + if (get_previous_number (ranges, next_number) != EOF) { + call printf ("Previous number is %d\n") + call pargi (next_number) + } + } +end |