diff options
| author | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
|---|---|---|
| committer | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
| commit | fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 (patch) | |
| tree | bdda434976bc09c864f2e4fa6f16ba1952b1e555 /noao/twodspec/longslit | |
| download | iraf-linux-fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4.tar.gz | |
Initial commit
Diffstat (limited to 'noao/twodspec/longslit')
129 files changed, 33509 insertions, 0 deletions
diff --git a/noao/twodspec/longslit/Revisions b/noao/twodspec/longslit/Revisions new file mode 100644 index 00000000..e90bbb37 --- /dev/null +++ b/noao/twodspec/longslit/Revisions @@ -0,0 +1,1003 @@ +.help revisions Jun88 noao.twodspec.longslit +.nf + +transform/trsetup.x +transform/igsfit/igscolon.x +fitcoords.par + 1. The fitcoords fitting orders can not be set to less than 2. + 2. There is an attempt to avoid divide by zero in trsetup.x. + (2/1/11, Valdes) + +===== +v2.15 +===== + +transform/t_transform.x +lscombine/t_lscombine.x + Replaced xt_mappm to yt_mappm thus supporting world coordinate pixel mask + matching. (1/16/08, Valdes) + +===== +V2.14 +===== + +===== +V2.13 +===== + +transform/trsetup.x + Conversion between natural and log coordinates had precision problems. + The conversions are now done in double precision. Added limits to + insure the interpolation coordinates for msivector remain in the + image. (8/7/07, Valdes) + +transform/fcgetcoords.x + The previous change failed to reset the axis mapping which causes the + transformation from physical to logical to fail when the trace axis + is 2. (6/14/06, Valdes) + +getdaxis.x + Put an error check to avoid an error when the WCS is 3D. (9/22/05, Valdes) + +transform/igsfit/igsfit.x + The computation of the rms was not handling deleted points. + (7/14/05, Valdes) + +standard.par + The file needed to be updated for the changes in the task for supporting + IR reductions. (9/10/04, Valdes) + +doc/fitcoords.hlp + Fixed wording. (8/25/04, Cooke & Valdes) + +transform/fcgetcoords.x +transform/icgsfit/igssolve.x + It is now possible to do a solution using a single column or line of + fiduciary points. (8/25/04, Cooke & Valdes) + +======== +V2.12.2a +======== + +transform/t_transform.x + Fixed a typo nxin -> nyin. (7/8/04, Valdes) + +lscombine/ + +lscombine.par + +mkpkg +x_longslit.x +longslit.hd +longslit.men +longslit.cl +doc/lscombine.hlp + + 1. Added the new task LSCOMBINE to register and combine longslit data. + This is a combination of the functions in TRANSFORM for resampling + and IMCOMBINE for combining. + +transform/trsetup.x + +transform/t_transform.x +transform/transform.com +transform/mkpkg +transform.par +doc/transform.hlp + 1. Added the parameters "minput" and "moutput". This allows masks + to be transformed using the same transformation as the data. The + transformation procedures were modified to allow doing this + efficiently; i.e. doing it in parallel with the data transformation + using the same internal coordinate lookup maps. + 2. Added the parameter "blank" to allow setting the value for output + pixels interpolated from outside the input image. The value + INDEF produces the old behavior or extrapolating from the nearest + edge pixel in the input image. + 3. If no "fitnames" are specified the tasks now uses the WCS for + defining the transformation. This allows resampling dispersion + calibrated longslit data. + 4. The routines were restructured to allow calling the setup and + resampling from another task such as LSCOMBINE. + (6/18/04, Valdes) + +======= +V2.12.2 +======= + +longslit$transform/t_fceval.x + +longslit$transform/fceval.par + +longslit$doc/fceval.hlp + +longslit$transform/mkpkg +longslit$x_longslit.x +longslit$longslit.cl +longslit$longslit.hd + New task to evaluate FITCOORDS solutions added. (8/27/03, Valdes) + +longslit$transform/fcgetcoord.x + Features in the IDENTIFY database with zero weight are now ignored. + (7/22/02, Valdes) + +======= +V2.12.1 +======= +===== +V2.12 +===== + +longslit$response.x + Fixed argument errors in calls to ic_g* routines. (1/7/02, Valdes) + +longslit$transform/mkpkg + Added missing <mach.h> dependency for fcdlist.x (12/13/01, MJF) + +longslit$response.x +longslit$doc/response.hlp + Modified to update the fitting parameters to the parameter set. + (9/20/01, Valdes) + +longslit$doc/fitcoords.hlp + Added that 'p' works as unzoom. (8/15/01, Valdes) + +longslit$transform/fcdlist.x + The check between a deleted point and the values read from the IDENTIFY + database are no tolerance checked. See bug 485. (8/15/01, Valdes) + +longslit$transform/t_transform.x + 1. Instead of using 50 sample points across the image for the sampled + inversion points the algorithm now sets a step near 10. In the + former method the sampling would become too crude with larger + images. + 2. Formerly the inversion would quit after one or two iterations if + the point falls off the edge. This can lead to bad interpolation at + the edges if the distortion and requested output samples outside the + input image. The edge check has been removed. + (7/5/01, Valdes) + +longslit$doc/fitcoords.hlp + Added a description of the FITCOORDS database. (4/24/00, Valdes) + +igsfit.x +igsparams.x +igscolon.x +igsfit.com +mkpkg + Added an RMS to the graph title and the :show command. + (3/9/00, Valdes) + +========= +V2.11.3p1 +========= +========= +V2.11.3 +========= + +longslit$transform/mkpkg + Added missing dependency. (10/11/99, Valdes) + +longslit$transform/t_transform.x + The REFSPEC keywords are now deleted if present. (9/7/99, Valdes) + +======= +V2.11.2 +======= + +longslit$transform/ +longslit$transform/fcgetcoords.x + Added an error check for there only being one line or column measured. + (7/21/99, Valdes) + +longslit$transform/igsfit/igsfit.x + Added an error check for an error in the fitting. (7/21/99, Valdes) + +transform/t_transform.x + Updated for new interpolation types. (1/4/99, Valdes) + +======= +V2.11.1 +======= + +transform/fcgetcoords.x + Add an errchk on immap. Without this the task would give a segmentation + violation if for some reason it could not open the image section given + in the identify database. For example if the image was not present. + (11/20/98, Valdes) + +longslit.cl + aidpars was incorrectly defined to be aidpars.cl instead of aidpars.par. + (11/18/97, Valdes) + +===== +V2.11 +===== + +response.x + The previous change had a typo in line 264 where the index should be + j and not i. (7/10/97, Valdes) + +========= +V2.11Beta +========= + +response.x +doc/response.hlp + Change the behavior of the task with respect to the threshold parameter + to agree with the help page. Previously it replaced values below + the threshold by the threshold value in both the normalization and + the data prior to dividing. The result would not be a unit response + unless both the data and normalization were below the threshold. + The new behavior gives a unit response if either the normalization + or data are below the threshold. The help page was slightly + modified to make the behavior even clearer. (5/15/97, Valdes) + +doc/response.help + Fixed formating typo. (5/15/97, Valdes) + +reidentify.par + Change default threshold value to 0. (4/22/97, Valdes) + +doc/fluxcalib.hlp + Fixed missing task name in revisions section. (4/22/97, Valdes) + +demos$mktest.cl +demos$mktestt.cl + Made the ARTDATA package parameters explicit. (4/15/97, Valdes) + +transform/fitcoords.x +transform/fcfitcoords.x +transform/fcgetcoords.x +transform/mkpkg + Added error checking for missing database, missing database file, + no coordinates, all INDEF coordinates. (2/21/96, Valdes) + +doc/illumination.hlp + Fixed a formating error (font change). (10/15/96, Valdes) + +transform/fcgetcoords.x + A rotated WCS is ignored in the same way as IDENTIFY. + (1/4/96, Valdes) + +======= +V2.10.4 +======= + +doc/response.hlp +doc/illumination.hlp +doc/extinction.hlp +doc/fluxcalib.hlp + Added note that DISPAXIS refers to the original dispersion axis in + transposed images. (7/31/95, Valdes) + +longslit.cl +longslit.men + Added the new SFLIP task to the package. (7/18/94, Valdes) + +transform/t_transform.x + The last interval of the inversion surface could be distorted by the + limitation of the inversion coordinats to be within the input image. + This limit was removed (with the out of bounds checking taking place + later). (9/19/93, Valdes) + +============ +V2.10.3 beta +============ + +transform/fcgetcoords.x +transform/t_transform.x + Modified to allow transposed axes. (5/14/93, Valdes) + +getdaxis.x + +response.x +illumination.x +extinction.x +fluxcalib.x +transform/t_transform.x + Access to the dispersion axis is now through the routine get_daxis. This + routine checks for transposed images. (5/14/93, Valdes) + +longslit.men +longslit.par +longslit.cl +standard.par + +sensfunc.par + +calibrate.par + +identify.par - +reidentify.par +demos$test.cl +demos$xgtest.dat + +demos$gtest.dat - +demos$xtest.dat - + 1. Added commonly used tasks from the ONEDSPEC package. + 2. Added additional package paraemters required by the ONEDSPEC tasks. + 3. Modified the test playback for the new package and XGTERM. + 4. Removed playbacks for XTERM and GTERM. + (2/12/93, Valdes) + +transform/fcgetcoords.x + If the combine option is used and the images do not all have the same + fit axis then a segmentation error would occur because of a mistake + in where the MWCS and IMIO pointers are closed. This was fixed + and a warning message added. (12/7/92, Valdes) + +transform/fcgetcoords.x + Features with INDEF user values are now excluded. + (11/11/92, Valdes) + +transform/t_transform.x + Added DCLOG1 keyword. This goes along with the changes in DISPCOR + to allow multiple dispersion corrections. (10/19/92, Valdes) + +fluxcalib.x + Loosened the wavelength limit checks so that an warning is only given + if the image wavelengths extend outside the calibration wavelengths + by more than a half pixel. (9/10/92, Valdes) + +demos/* + +longslit.cl +longslit.men + Added a demos task with a test playback. (7/24/92, Valdes) + +======= +V2.10.2 +======= + +======= +V2.10.1 +======= + +======= +V2.10.0 +======= + +transform/t_transform.x + It was possible to end up with too few lines for MSIFIT. A minimum + buffer size is now enforced. (6/18/92, Valdes) + +transform/t_transform.x + Modified to use MWCS. (5/20/92, Valdes) + +===== +V2.10 +===== + +longslit$fluxcalib.x +longslit$doc/fluxcalib.hlp + The output pixel type is now of type real. If the input image is + to be modified the calibration is done on a temporary image and + renamed to the input image upon completion rather than being done + in place. Previously, flux calibrating a type short image would + produce an image of all zeros. (3/19/92, Valdes) + +longslit$longslit.par + Added observatory to package parameters. + (2/6/92, Valdes) + +longslit$transform/fcgetcoords.x + In V2.10 IDENTIFY/REIDENTIFY measure feature positions in physical + coordinates while FITCOORDS and TRANSFORM require logical coordinates. + Therefore, the IDENTIFY database coordinates are transformed to + logical coordinates when they are read. (12/20/91, Valdes) + +longslit$transform/igsfit/igsfit.x + Removed the print statement about fitting because this caused the graphics + to be overplotted on the previous graph for some unknown reason. + (12/12/91, Valdes) + +longslit$doc/extinction.hlp +longslit$doc/fluxcalib.hlp +longslit$doc/illumination.hlp +longslit$doc/response.hlp + Added discussion and example about the DISPAXIS keyword. (12/6/91, Valdes) + +longslit$t_transform.x + Fixed datatype declaration error for array tmp. This was a harmless + error. (11/21/91, Valdes) + +longslit$longslit.par +longslit$response.x +longslit$illumination.x +longslit$fluxcalib.x +longslit$extinction.x +longslit$transform/t_transform.x + 1. Added dispaxis parameter to package parameters. + 2. Modified all routines to use package dispaxis if not found in image + all also write it to header. (8/28/91, Valdes) + +longslit$transform/t_transform.x + Removed W0 and WPC from output image. (8/28/91, Valdes) + +longslit$transform/igsfit/igssolve.x + The case of a single trace along x handled by igs_solve3 was using the + yorder instead of the xorder in one place. (7/11/91, Valdes) + +longslit$transform/t_transform.x + The interative inversion was made more stable by using a fudge factor. + This was needed to make the LONGSLIT test procedure work on HPUX. + (9/17/90, Valdes) + +longslit$identify.par +longslit$reidentify.par + Updated parameter files for the new version. (8/23/90, Valdes) + +longslit$transform/t_transform.x + Changed the computation of the output grid from a cumulative addition of + the pixel increment to a direct calculation to avoid cumulative + round off errors in high resolution data. (7/19/90, Valdes) + +longslit$doc/lslit.ms + + Added copy of the SPIE paper on the LONGSLIT package. It is in MS TROFF + format. Postscript copies may be obtained from the FTP archive. + (7/4/90, Valdes) + +==== +V2.9 +==== + +longslit$transform/igsfit +longslit$transform/t_transform.x +longslit$fluxcalib.x +longslit$extinction.x + Added use of CD keywords in addition to CDELT. (3/8/90, Valdes) + +longslit$transform/igsfit/igsfit.x + 1. Changed incorrect usage of abscissa/ordinate. + 2. Cleared prompts after input. + (3/6/90, Valdes) + +longslit$transform/fcgetcoords.x + Fixed problem in which database files where opened within a loop but + only closed once outside a loop. (5/6/89, Valdes - reported by Schaller) + +longslit$illumination.x + 1. Added error checking to handle missing DISPAXIS keyword. + 2. Changed to dynamically allocated strings. + (2/28/89, Valdes) + +longslit$ilsetbins.x + 1. The "bins" string is now checked for null after stripping any + leading whitespace with xt_stripwhite. + 2. The ":bins" command with no argument will not clear the bins now. + 3. An error message is printed if two many sky bins are defined + using the cursor. + (1/26/89, Valdes) + +longslit$fluxcalib.x + 1. Changed CRPIXn keyword and variable to type real. + 2. Added the ONEDSPEC flag for flux calibration. + (1/26/89, Valdes) + +longslit$response.x +longslit$illumination.x + Added header keywords CCDMEAN and MKILLUM for compatibility with CCDRED. + (12/14/88 Valdes) + +longslit$transform/t_transform.x + Changed the computation of x1, x2 and y1, y2 to natural units if logx and + logy were set to yes. These numbers were being erroneously computed in + log units leading to an erroneous transformation if the user specified the + coordinate limits with x1,nx,dx and y1,ny,dy. (10/26/88 Davis) + +longslit$t_longslit.x + Changed the units of w0 to be log (w0) if log=yes. (9/21/88 Davis) + +longslit$ilsetbins.x +longslit$transform/igsfit/igsfit.x +noao$lib/scr/ilsetbins.key +noao$lib/scr/igsfit.key + Added 'I' interrupt key. (4/20/88 Valdes) + +longslit$mkpkg +longslit$longslit.cl +longslit$x_longslit.x +longslit$transform/mkpkg +longslit$transform/igsfit/mkpkg +longslit$transform/x_transform.x - +longslit$transform/libpkg.a - +longslit$transform/fitcoords.par -> longslit$fitcoords.par +longslit$transform/transform.par -> longslit$transform.par + Merged tranform executable with the longslit executable. (4/7/88 Valdes) + +longslit$transform/extinction.x + Was incorrectly doing in place correction. (3/24/88 Valdes) + +longslit$ilsetbins.x + Increased bin string from SZ_LINE to 2048 chars. Some users have attempted + to define a large number of bins which fails when the string limit is + reached. (1/4/88 Valdes) + +longslit$transform/fluxcalib.x + Was incorrectly doing in place correction. (11/5/87 Valdes) + +longslit$transform/transform.x - +longslit$transform/trtransform.x - +longslit$transform/trgetsurface.x - +longslit$transform/trsftomsi.x - +longslit$transform/trsetoutput.x - +longslit$transform/t_transform.x + +longslit$doc/transform.hlp + The task TRANSFORM in the LONGSLIT package is used to + interpolate images onto a user defined coordinate system given as + surface functions U(X,Y) and V(X,Y) where (X,Y) are the + untransformed image pixel coordinates and (U,V) are the user + coordinates. The surface functions are derived from a set of measured + points using the task FITCOORDS. With Version 2.6 of IRAF + the algorithm used to invert the user coordinate surfaces, U(X,Y) + and V(X,Y) --> X(U,V) and Y(U,V), has been changed. Previously, + surfaces function of comparable order to the original surfaces were + fit to a grid of points, i.e. (U(X,Y), V(X,Y), X) and (U(X,Y), + V(X,Y), Y), with the same surface fitting routines used in FITCOORDS to + obtain the input user coordinate surfaces. This method of inversion + worked well in all cases in which reasonable distortions and + dispersions were used. It was selected because it was relatively + fast. However, it cannot be proved to work in all cases; in + one instance in which an invalid surface was used the + inversion was actually much poorer than expected. Therefore, a more + direct iterative inversion algorithm is now used. This is + guaranteed to give the correct inversion to within a set error + (0.05 of a pixel in X and Y). It is slightly slower than the previous + algorithm but it is still not as major a factor as the image + interpolation itself. + + The event which triggered this change was when a user + misidentified some arc lines. The dispersion function which was + forced to fit the misidentified lines required curvatures of + a couple of hundred angstroms over 100 pixels at a dispersion of + 10 angstroms per pixel. It was possible to do this to the user's + satisifaction with a surface function of xorder=6 and yorder=7. + TRANSFORM inverts this surface by fitting a function with the + same orders (it uses a minimum of order 6 and the order of the input + surface function). The transformed arc image was then examined + and found to have residual wavelength errors 5 times larger expected + from the residuals in the dispersion solution. With such a + large curvature in the dispersion surface function it turned out + that to maintain errors at the same level the fitting function + required orders of 12. (To determine this required a special version + of TRANSFORM and the new double precision surface fitting + routines). When the lines were correctly identified the + dispersion function had much lower curvatures and required lower orders + in the fit and gave a good transformation of the arc image. The + conclusions drawn from this event are: + + 1. An incorrect dispersion solution can appear to be correct if + the misidentified lines are at the end and a high enough order is + used. + + 2. This requires high order surface functions in FITCOORDS + and TRANSFORM. + + 3. The algorithm used in TRANSFORM in V2.5 and earlier, while + not failing, does give unexpectly large residuals in the + linearized arc spectrum in this case. A cautious user should transform + arc images and examine them. + + 4. In the future a more direct inversion algorithm is guaranteed + to give residuals in the transform consistent with the residuals in + the dispersion solution even when the dispersion function is not + realistic. + (9/14/87 Valdes) + +longslit$transform/trgetsurface.x +longslit$transform/fcfitcoords.x +longslit$transform/fcdbio.x +longslit$transform/trsftomsi.x +longslit$transform/trsetoutput.x +longslit$transform/igsfit/igsfit.x +longslit$transform/igsfit/igscolon.x +longslit$transform/igsfit/igssolve.x +longslit$transform/igsfit/igsget.x +longslit$transform/igsfit/xgs.x + + Modified routines using the GSURFIT routines to call an interface routine + which allows calling the double precision versions of these procedures + without changing the single precision data arrays (a double precision + copy is made within the interface). Thus, FITCOORDS and TRANSFORM now + use double precision arithmetic when doing surface fitting and evaluating. + This removes the problems experienced with high order surfaces. + (8/14/87 Valdes) + +longslit$transform/igsfit/igsfit.x +longslit$transform/igsfit/igsget.x +longslit$transform/igsfit/igscolon.x +longslit$doc/fitcoords.hlp +noao$lib/scr/igsfit.key + Added a listing of the fitted surface values at the corners of the + image. This allows evaluating the fit. (8/8/87 Valdes) + +longslit$transform/fitcoords.x + Added check against using blanks in fitname prefix instead of null + file. (7/3/87 Valdes) + +==== +V2.5 +==== + +longslit$extinction.x +longslit$extinction.par +longslit$doc/extinction.hlp + Valdes, May 26, 1987 + 1. EXTINCTION now uses the same extinction files used by the ONEDSPEC + package. + 2. The parameter name for the extinction file has been changed from + "table" to "extinction" to be consistent with the ONEDSPEC parameter. + 3. The help page was updated. + +longslit$longslit.cl +longslit$identify.par + +longslit$reidentify.par + + Valdes, April 16, 1986 + 1. Parameters for IDENTIFY and REIDENTIFY are now separate for the + LONGSLIT package. + +longslit$fluxcalib.x + Valdes, March 16, 1987 + 1. A reference off the end of the sensitivity image due to an error + in a do loop index was fixed. + +longslit$transform/trtransform.x + Valdes, February 26, 1987 + 1. Add a warning if the header parameter DISPAXIS is not found. This + affects whether coordinate information for ONEDSPEC is produced. + +longslit$*.x + Valdes, February 17, 1987 + 1. Required GIO changes. + +longslit$transform/igsfit/igsdelete.x +longslit$transform/igsfit/igsundelete.x + Valdes, October 16, 1986 + 1. Real line type specified in gseti call changed to integer. + This caused a crash on AOS/IRAF. + +longslit$doc/fluxcalib.hlp + Valdes, October 8, 1986 + 1. Added a short paragraph discussing calibration of logarithmicly + binned spectra. + +longslit$response.x +longslit$response.par +longslit$doc/response.hlp + Valdes, August 18, 1986 + 1. RESPONSE was modified to allow separately specifying the image + section to be used to determine the response (the numerator) + and the image section used to derive the normalization spectrum + (the denominator). The help page was also modified. + +==================================== +Version 2.3 Release, August 18, 1986 +==================================== + +longslit$doc: Valdes, July 9, 1986 + 1. Help page and menu file (noao$lib/scr/ilsetbins.key) for ILLUMINATION + were updated since they mention colon commands which do not exist. + 2. Help page for EXTINCTION updated to reflect new name for extinction + file. + 3. Date of help page for FITCOORDS updated to because of new window + command. + +longslit$fitcoords.x: Valdes, July 7, 1986 + 1. Keys 'a' and 'e' replaced with the general 'w' window package. + 2. Help page updated. + +longslit$response.x, illumination.x: Valdes, July 3, 1986 + 1. RESPONSE and ILLUMINATION modified to use new ICFIT package. + +transform/fitcoords.x,fcgetcoords.x,fcgetim.x: Valdes, July 1, 1986 + 1. Added routine to remove image extensions. This was necessary + to prevent having two legal image names and to avoid creating + database files with the image extensions. + +===================================== +STScI Pre-release and SUN 2.3 Release +===================================== + +longslit$illumination.x: Valdes, June 17, 1986: + 1. It was possible to request a higher order image interpolator + than the number of bins being interpolated causing an error. + A check was added to use a lower order interpolator if the + number of bins is too small. + +longslit$*.ext; Valdes June 2, 1986 + 1. Moved the extinction data files to "noao$lib/onedstds/". + Modified the parameter file for EXTINCTION appropriately. + +longslit$fluxcalib.x: Valdes, May 13, 1986 + 1. Modified FLUXCALIB to allow any combination of log or linear wavelength + coordinates for the input image and the sensitivity image. + +longslit$fluxcalib.x: Valdes, May 1, 1986 + 1. Modified FLUXCALIB to use image templates instead of file templates. + +longslit$tranform/transform.par: Valdes, May 1, 1986 + 1. Changed default value of parameter database to "database" from + "identify.db" + 2. Changed help page to reflect change in default parameter. + +longslit$tranform/transform.x: Valdes, April 21, 1986 + 1. Task TRANSFORM crashed when flux conservation was turned off. This + was caused at the end by attempting to free memory allocated for + flux conservation. The transformed image is still ok. This + bug has been fixed. + 2. Help page for TRANSFORM updated to include timing information. + +longslit$ilsetbins.x: Valdes, April 7, 1986 + 1. Fixed use of STRIDX with a character constant to STRIDXS. + +longslit: Valdes, Mar 24, 1986 + 1. RESPONSE, ILLUMINATION, EXTINCTION, and FLUXCALIB modified to + fix history writing bug. + +longslit: Valdes, Mar 21, 1986 + 1. APDEFINE, APEXTRACT, and SETIMHDR removed from this package. + 2. APDEFINE, APEXTRACT, and SETIMHDR help pages removed. + 3. LONGSLIT menu revised. + +longslit$response.x: Valdes, Mar 20, 1986 + 1. There was a bug in RESPONSE which turned the interactive fitting + off if the answer was only "no" instead of "NO". This has been + fixed. + +longslit$illumination.x: Valdes, Mar 11, 1986 + 1. ILLUMINATION has a new parameter for the interpolation type. + 2. The help page for ILLUMINATION has been updated + +=========== +Release 2.2 +=========== +From Valdes Feb 11, 1986: + +1. APEXTRACT sets the BEAM_NUM beam number to zero for all extractions. +The aperture numbers are used to generate the record extensions. +------ +From Valdes Feb 7, 1986: + +1. Images package loaded with longslit. +------ +From Valdes Feb 3, 1986: + +1. Fixed bug in setting the aperture number in APDEFINE. It was interpreting +the input value as a real number and storing it in an integer variable. +------ +From Valdes Jan 23, 1986: + +1. Buffering limits removed in TRANSFORM. + +2. Bug fixed in coordinate setting in TRANSFORM. + +3. Bug fixed in undeleting points in FITCOORDS. +------ +From Valdes Jan 3, 1986: + +1. FITCOORDS has been modified. The 'z' zoom option now queries for +the type of zoom. The types are feature, constant x, constant y, and +constant z. This allows examining dispersion solutions at different +columns or lines. +------ +From Valdes Nov 20, 1985: + +1. TRANSFORM now exits with an error if a database record is not found +rather than giving a warning and continuing on. +------ +From Valdes Nov 15, 1985: + +1. FITCOORDS and TRANSFORM modified to use directory/text databases +rather than single text databases. This new database structure is what +is now created by IDENTIFY and REIDENTIFY. +------ +From Valdes Nov 7, 1985: + +1. The task MKSCRIPT has been made a basic system task. It is no longer +loaded in the LONGSLIT package but is always available. +------ +From Valdes Nov 1, 1985: + +1. New task MKSCRIPT has been added. It is loaded out of the IMRED.GENERIC +package. See the help page for the task and the revisions for GENERIC. + +2. Task FITCOORDS has been modified in several ways: + a. The images in a list of images can be fit separately or + combined into a single fit based on the value of the parameter + COMBINE. + b. Points delete interactively are recorded in a deletion list + and may be used in subsequent fits. + c. The last interactive plot or a default non-interactive plot + is recorded in a plotfile (if specified). The plots in the + plot file can be spool or examined after the fact. + +See the new help for this task. +------ +From Valdes Oct 22, 1985: + +1. New parameter "exposure" in FLUXCALIB. This parameter specifies the +image header keyword corresponding to the exposure time to be used in +calibrating the images. + +2. FLUXCALIB and EXTINCTION have been changed to take a list of input +images and a list of output images. The output images may be the same +as the input images. +------ +From Valdes Oct 4, 1985: + +1. Response and illumination modified to include the parameters for +low and high rejection and rejection iteration. +------ +From Valdes Oct 1, 1985: + +1. The package has been reorganized. Task extract has been moved to +a new package twodspec.echelle. The source code for identify and reidentify, +which are actually one dimensional tools, have been moved to the onedspec +package though they are still loaded with the twodspec package. + +2. New task fluxcalib flux calibrates long slit images using the flux +calibration file produced by onedspec.sensfunc. + +3. Illumination can now handle using a single illumination bin. + +4. Task revisions renamed to revs. Note that this is a temporary task. +------ +From Valdes September 25, 1985: + +1. New task setimages added. This task sets parameters in the image headers +defining the dispersion axis and, optionally, strings for the coordinate +types and coordinate units. This strings, if defined, are used in other +tasks for identifying and labeling graphs. + +2. Because the dispersion axis is now defined in the header the axis +parameter in tasks response and illumination have been removed. + +3. Task transform now adds coordinate information to the image headers. + +4. New task extinction corrects images for extinction. + +------ +From Valdes September 23, 1985: + +1. Reidentify has been significantly speeded up when tracing a 2D image +by eliminating most database accesses. +------ +From Valdes August 6, 1985: + +1. A bug in the absorption feature centering was fixed. +2. Numerous cosmetic changes in the graphics are being made. These will +be documented later. +------ +From Valdes August 1, 1985: + +1. The icfit package has been modified to allow resetting the x and +y fitting points with keys 'x' and 'y'. This is useful in identify +to reset the user coordinates directly in the fitting package. + +2. The :features command in identify now takes an (optional) file name +directing the feature information to the specified file. Without a +file the terminal is cleared and the information written to the terminal +with a pause at the end. With a file name the information is appended to +the specified file. + +3. A couple of small bugs in the handling of INDEF user coordinates in +identify have been fixed. + +4. The default pixel range in the icfit package when called from identify +is now the full image range rather than the range of points to be fit. + +5. The image section in identify is now used with :image just as it is +used for images given as arguments to the task. Explicit image sections +must be given, however, in database :read and :write because the optional +names to these commands need not be image names. +------ +From Valdes July 30, 1985: + +1. The tasks lsmap, lstrans, and reidentify have been changed so that +the user may specify a list of log files instead of just one logfile. +Now it is possible to have log output be written to the terminal +as well as a disk file. This is now the default. +------ +From Valdes July 27, 1985: + +1. The default user coordinate when marking a feature in identify +is the pixel coordinate if there is no coordinate function. + +2. When entering a user coordinate in identify after a (m)ark or +(u)ser key the coordinate typed by the user is matched against the +line list and the line list value substituted if a match is found. +Thus, for wavelengths the user only needs to enter the wavelength to +the nearest Angstrom and the decimal part will be found from the +coordinate list. + +3. Response and illumination have been modified to work along either +image axis. A new parameter "axis" has been added to select the +axis. For response the axis should be along the dispersion (default +is along the columns) and in illumination the axis is that slit position +axis (the default is along the lines). These changes in conjunction +with the new flat1d, fit1d, and background make the orientation of the +longslit images arbitrary! + +4. The values in the default parameter files for response, illumination, +identify, reidentify, lsmap, and lstrans have been changed. This will +cause user parameter files to be out of date. Sorry about that. +------ +From Valdes July 26, 1985: + +1. Background has been modified to use new fit1d task. It now does +column backgrounds without transposes and allows image sections. +------ +From Valdes July 23, 1985: + +1. Task lsrevisions has been renamed to revisions. The intent is that +each package will have a revisions task. Note that this means there may +be multiple tasks named revisions loaded at one time. Typing revisions +alone will give the revisions for the current package. To get the system +revisions type system.revisions. + +2. Background now does both line and column backgrounds. +______ +July 18, 1985: + +1. Help page for extract is available. +2. Help page for lsrevisions is available. +______ +July 17, 1985: + +1. Extract has been modified to allow interactively setting the +extraction limits for each trace. If this is not needed then answer +NO to the query. Any changes made in lower and upper remain +in effect to subsequent traces. The lower and upper limits are written +to the database. Older database tracings are still useable as before. +______ +July 16, 1985: + +1. A new task, lsrevisions, has been added to record revisions to the +beta test version of the package. + +2. A help page for identify is now available! + +3. A default one dimensional image section is available in the tasks +identify, reidentify, and extract. This allows use of two dimensional +images (without an image section) to be used without bothering with +the image section. It is also a little more general than regular image +sections in that a special format in terms of lines or columns can be given. +The default section is the "middle line". + +4. Extract has been changed to allow: + + a. Recording the traced curves. + b. Using the traced curves from one image to extract from another image. + +This is done by having three query parameters giving the name of the +image to be traced or which was previously traced, a list of input +images from which to extract, and a list of output rootnames +one for each input image. + + +.: +total 4520 +-rw-r--r-- 1 valdes iraf 1423 Sep 24 1985 airmass.x +-rw-r--r-- 1 valdes iraf 245 Oct 22 1985 fluxcalib.par +-rw-r--r-- 1 valdes iraf 659 Nov 18 1985 fitcoords.par +-rw-r--r-- 1 valdes iraf 879 Mar 13 1986 illumination.par +-rw-r--r-- 1 valdes iraf 3108 Jun 2 1986 lstools.x +-rw-r--r-- 1 valdes iraf 800 Aug 18 1986 response.par +-rw-r--r-- 1 valdes iraf 183 May 26 1987 extinction.par +-rw-r--r-- 1 valdes iraf 5297 Feb 3 1989 ilsetbins.x +-rw-r--r-- 1 valdes iraf 493 Feb 12 1993 calibrate.par +-rw-r--r-- 1 valdes iraf 950 Feb 12 1993 sensfunc.par +-rw-r--r-- 1 valdes iraf 758 Feb 12 1993 standard.par +-rw-r--r-- 1 valdes iraf 496 Feb 12 1993 longslit.par +-rw-r--r-- 1 valdes iraf 8574 May 14 1993 fluxcalib.x +-rw-r--r-- 1 valdes iraf 690 May 14 1993 getdaxis.x +-rw-r--r-- 1 valdes iraf 10216 May 14 1993 illumination.x +-rw-r--r-- 1 valdes iraf 5996 May 14 1993 extinction.x +-rw-r--r-- 1 valdes iraf 1567 Jul 21 1997 reidentify.par +drwxr-xr-x 2 valdes iraf 4096 Aug 12 1999 demos +-rw-r--r-- 1 valdes iraf 9206 Jan 7 2002 response.x +-rw-r--r-- 1 valdes iraf 171 Aug 27 2003 fceval.par +-rw-r--r-- 1 valdes iraf 30895 Aug 27 2003 Revisions +-rw-r--r-- 1 valdes iraf 212 Jun 10 14:38 x_longslit.x +-rw-r--r-- 1 valdes iraf 12252 Jun 10 14:38 x_longslit.o +-rw-rw-r-- 1 valdes iraf 17479 Jun 15 16:16 xtpmmap.x +-rw-rw-r-- 1 valdes iraf 3240 Jun 16 11:30 xtmaskname.x +-rw-r--r-- 1 valdes iraf 13080 Jun 16 11:43 xtmaskname.o +-rw-r--r-- 1 valdes iraf 46608 Jun 16 11:43 xtpmmap.o +-rw-r--r-- 1 valdes iraf 841 Jun 16 11:49 transform.par +-rw-r--r-- 1 valdes iraf 804 Jun 16 17:12 mkpkg +drwxr-xr-x 3 valdes iraf 4096 Jun 16 17:53 transform +-rw-r--r-- 1 valdes iraf 1613602 Jun 16 18:06 libpkg.a +-rwxr-xr-x 1 valdes iraf 2714998 Jun 16 18:06 xx_longslit.e +drwxrwxr-x 3 valdes iraf 4096 Jun 18 16:07 lscombine +-rw-r--r-- 1 valdes iraf 2331 Jun 18 16:25 lscombine.par +drwxr-xr-x 2 valdes iraf 4096 Jun 18 16:50 doc +-rw-r--r-- 1 valdes iraf 376 Jun 18 16:50 longslit.hd +-rw-r--r-- 1 valdes iraf 1499 Jun 18 16:51 longslit.men +-rw-r--r-- 1 valdes iraf 776 Jun 18 16:52 longslit.cl diff --git a/noao/twodspec/longslit/airmass.x b/noao/twodspec/longslit/airmass.x new file mode 100644 index 00000000..d47fab2d --- /dev/null +++ b/noao/twodspec/longslit/airmass.x @@ -0,0 +1,60 @@ +include <math.h> + +# IMG_AIRMASS -- Get or compute the image airmass from the image header. +# If the airmass cannot be determined from header then INDEF is returned. +# +# Airmass formulation from Allen "Astrophysical Quantities" 1973 p.125,133 +# and John Ball's book on Algorithms for the HP-45. + +real procedure img_airmass (im) + +pointer im # IMIO pointer + +real airmass, zd, ha, ra, dec, st, latitude, coszd, scale, x + +int imaccf() +real imgetr() +errchk imgetr() + +data scale/750.0/ # Atmospheric scale height approx + +begin + # If the airmass is in the header return its value. + + if (imaccf (im, "airmass") == YES) + return (imgetr (im, "airmass")) + + # Compute zenith distance if not defined. + + iferr (zd = imgetr (im, "zd")) { + + # Compute hour angle if not defined. + + iferr (ha = imgetr (im, "ha")) { + st = imgetr (im, "st") + ra = imgetr (im, "ra") + ha = st - ra + call imaddr (im, "ha", ha) + } + + dec = imgetr (im, "dec") + latitude = imgetr (im, "latitude") + + ha = DEGTORAD (ha) * 15 + dec = DEGTORAD (dec) + latitude = DEGTORAD (latitude) + coszd = sin (latitude) * sin (dec) + + cos (latitude) * cos (dec) * cos (ha) + zd = RADTODEG (acos (coszd)) + call imaddr (im, "zd", zd) + } + + # Compute airmass from zenith distance. + + zd = DEGTORAD (zd) + x = scale * cos (zd) + airmass = sqrt (x ** 2 + 2 * scale + 1) - x + call imaddr (im, "airmass", airmass) + + return (airmass) +end diff --git a/noao/twodspec/longslit/calibrate.par b/noao/twodspec/longslit/calibrate.par new file mode 100644 index 00000000..4cf9f810 --- /dev/null +++ b/noao/twodspec/longslit/calibrate.par @@ -0,0 +1,11 @@ +# CALIBRATE parameter file + +input,s,a,,,,Input spectra to calibrate +output,s,a,,,,Output calibrated spectra +extinct,b,h,yes,,,Apply extinction correction? +flux,b,h,yes,,,Apply flux calibration? +extinction,s,h,"onedstds$kpnoextinct.dat",,,Extinction file +observatory,s,h,)_.observatory,,,Observatory of observation +ignoreaps,b,h,yes,,,Ignore aperture numbers in flux calibration? +sensitivity,s,h,"sens",,,Image root name for sensitivity spectra +fnu,b,h,no,,,Create spectra having units of FNU? diff --git a/noao/twodspec/longslit/demos/demoarc1.dat b/noao/twodspec/longslit/demos/demoarc1.dat new file mode 100644 index 00000000..fa0a179d --- /dev/null +++ b/noao/twodspec/longslit/demos/demoarc1.dat @@ -0,0 +1,38 @@ + OBJECT = 'First comp ' / object name + OBSERVAT= 'KPNO ' / observatory + OBSERVER= 'Massey ' / observers + COMMENTS= 'Final New Ice ' / comments + EXPTIME = 60. / actual integration time + DARKTIME= 60. / total elapsed time + IMAGETYP= 'comp ' / object, dark, bias, etc. + DATE-OBS= '26/11/91 ' / date (dd/mm/yy) of obs. + UT = '12:11:30.00 ' / universal time + ST = '09:04:54.00 ' / sidereal time + RA = '06:37:02.00 ' / right ascension + DEC = '06:09:03.00 ' / declination + EPOCH = 1991.9 / epoch of ra and dec + ZD = '48.760 ' / zenith distance + AIRMASS = 0. / airmass + TELESCOP= 'kpcdf ' / telescope name + DETECTOR= 'te1k ' / detector + PREFLASH= 0 / preflash time, seconds + GAIN = 5.4 / gain, electrons per adu + DWELL = 5 / sample integration time + RDNOISE = 3.5 / read noise, electrons per adu + DELAY0 = 0 / time delay after each pixel + DELAY1 = 0 / time delay after each row + CAMTEMP = -111 / camera temperature + DEWTEMP = -183 / dewar temperature + CCDSEC = '[97:134,2:1023]' / orientation to full frame + ORIGSEC = '[1:1024,1:1024] ' / original size full frame + CCDSUM = '1 1 ' / on chip summation + INSTRUME= 'test ' / instrument + APERTURE= '250micron slit ' / aperture + TVFILT = '4-96 ' / tv filter + DISPAXIS= '2 ' / dispersion axis + GRATPOS = 4624.3 / grating position + TRIM = 'Nov 26 5:44 Trim data section is [23:60,2:1023]' + OVERSCAN= 'Nov 26 5:44 Overscan section is [103:133,2:1023] with mean=611.1 + ZEROCOR = 'Nov 26 5:44 Zero level correction image is Zerof' + CCDMEAN = 179.398 + CCDPROC = 'Nov 26 5:44 CCD processing done' diff --git a/noao/twodspec/longslit/demos/demoarc2.dat b/noao/twodspec/longslit/demos/demoarc2.dat new file mode 100644 index 00000000..4cd9975d --- /dev/null +++ b/noao/twodspec/longslit/demos/demoarc2.dat @@ -0,0 +1,38 @@ + OBJECT = 'Last comp ' / object name + OBSERVAT= 'KPNO ' / observatory + OBSERVER= 'Massey ' / observers + COMMENTS= 'Final New Ice ' / comments + EXPTIME = 60. / actual integration time + DARKTIME= 60. / total elapsed time + IMAGETYP= 'comp ' / object, dark, bias, etc. + DATE-OBS= '26/11/91 ' / date (dd/mm/yy) of obs. + UT = '12:41:30.00 ' / universal time + ST = '09:34:54.00 ' / sidereal time + RA = '06:37:02.00 ' / right ascension + DEC = '06:09:03.00 ' / declination + EPOCH = 1991.9 / epoch of ra and dec + ZD = '48.760 ' / zenith distance + AIRMASS = 0. / airmass + TELESCOP= 'kpcdf ' / telescope name + DETECTOR= 'te1k ' / detector + PREFLASH= 0 / preflash time, seconds + GAIN = 5.4 / gain, electrons per adu + DWELL = 5 / sample integration time + RDNOISE = 3.5 / read noise, electrons per adu + DELAY0 = 0 / time delay after each pixel + DELAY1 = 0 / time delay after each row + CAMTEMP = -111 / camera temperature + DEWTEMP = -183 / dewar temperature + CCDSEC = '[97:134,2:1023]' / orientation to full frame + ORIGSEC = '[1:1024,1:1024] ' / original size full frame + CCDSUM = '1 1 ' / on chip summation + INSTRUME= 'test ' / instrument + APERTURE= '250micron slit ' / aperture + TVFILT = '4-96 ' / tv filter + DISPAXIS= '2 ' / dispersion axis + GRATPOS = 4624.3 / grating position + TRIM = 'Nov 26 5:44 Trim data section is [23:60,2:1023]' + OVERSCAN= 'Nov 26 5:44 Overscan section is [103:133,2:1023] with mean=611.1 + ZEROCOR = 'Nov 26 5:44 Zero level correction image is Zerof' + CCDMEAN = 179.398 + CCDPROC = 'Nov 26 5:44 CCD processing done' diff --git a/noao/twodspec/longslit/demos/demoflat.dat b/noao/twodspec/longslit/demos/demoflat.dat new file mode 100644 index 00000000..f4651c52 --- /dev/null +++ b/noao/twodspec/longslit/demos/demoflat.dat @@ -0,0 +1,37 @@ + OBJECT = 'Flat ' / object name + OBSERVAT= 'KPNO ' / observatory + OBSERVER= 'Massey ' / observers + COMMENTS= 'Final New Ice ' / comments + EXPTIME = 1200. / actual integration time + DARKTIME= 1200. / total elapsed time + IMAGETYP= 'flat ' / object, dark, bias, etc. + DATE-OBS= '26/11/91 ' / date (dd/mm/yy) of obs. + UT = '12:19:55.00 ' / universal time + ST = '09:13:15.00 ' / sidereal time + RA = '06:37:02.00 ' / right ascension + DEC = '06:08:52.00 ' / declination + EPOCH = 1991.9 / epoch of ra and dec + ZD = '44.580 ' / zenith distance + AIRMASS = 0. / airmass + TELESCOP= 'kpcdf ' / telescope name + DETECTOR= 'te1k ' / detector + PREFLASH= 0 / preflash time, seconds + GAIN = 5.4 / gain, electrons per adu + DWELL = 5 / sample integration time + RDNOISE = 3.5 / read noise, electrons per adu + DELAY0 = 0 / time delay after each pixel + DELAY1 = 0 / time delay after each row + CAMTEMP = -111 / camera temperature + DEWTEMP = -183 / dewar temperature + CCDSEC = '[97:134,2:1023]' / orientation to full frame + ORIGSEC = '[1:1024,1:1024] ' / original size full frame + CCDSUM = '1 1 ' / on chip summation + INSTRUME= 'test ' / instrument + APERTURE= '250micron slit ' / aperture + TVFILT = '4-96 ' / tv filter + DISPAXIS= '2 ' / dispersion axis + GRATPOS = 4624.3 / grating position + TRIM = 'Nov 26 5:44 Trim data section is [23:60,2:1023]' + OVERSCAN= 'Nov 26 5:44 Overscan section is [103:133,2:1023] with mean=611.1 + ZEROCOR = 'Nov 26 5:44 Zero level correction image is Zerof' + CCDPROC = 'Nov 26 5:44 CCD processing done' diff --git a/noao/twodspec/longslit/demos/demoobj.dat b/noao/twodspec/longslit/demos/demoobj.dat new file mode 100644 index 00000000..78f3b9ad --- /dev/null +++ b/noao/twodspec/longslit/demos/demoobj.dat @@ -0,0 +1,37 @@ + OBJECT = 'V640Mon 4500 ' / object name + OBSERVAT= 'KPNO ' / observatory + OBSERVER= 'Massey ' / observers + COMMENTS= 'Final New Ice ' / comments + EXPTIME = 1200. / actual integration time + DARKTIME= 1200. / total elapsed time + IMAGETYP= 'object ' / object, dark, bias, etc. + DATE-OBS= '26/11/91 ' / date (dd/mm/yy) of obs. + UT = '12:19:55.00 ' / universal time + ST = '09:13:15.00 ' / sidereal time + RA = '06:37:02.00 ' / right ascension + DEC = '06:08:52.00 ' / declination + EPOCH = 1991.9 / epoch of ra and dec + ZD = '44.580 ' / zenith distance + AIRMASS = 0. / airmass + TELESCOP= 'kpcdf ' / telescope name + DETECTOR= 'te1k ' / detector + PREFLASH= 0 / preflash time, seconds + GAIN = 5.4 / gain, electrons per adu + DWELL = 5 / sample integration time + RDNOISE = 3.5 / read noise, electrons per adu + DELAY0 = 0 / time delay after each pixel + DELAY1 = 0 / time delay after each row + CAMTEMP = -111 / camera temperature + DEWTEMP = -183 / dewar temperature + CCDSEC = '[97:134,2:1023]' / orientation to full frame + ORIGSEC = '[1:1024,1:1024] ' / original size full frame + CCDSUM = '1 1 ' / on chip summation + INSTRUME= 'test ' / instrument + APERTURE= '250micron slit ' / aperture + TVFILT = '4-96 ' / tv filter + DISPAXIS= '2 ' / dispersion axis + GRATPOS = 4624.3 / grating position + TRIM = 'Nov 26 5:44 Trim data section is [23:60,2:1023]' + OVERSCAN= 'Nov 26 5:44 Overscan section is [103:133,2:1023] with mean=611.1 + ZEROCOR = 'Nov 26 5:44 Zero level correction image is Zerof' + CCDPROC = 'Nov 26 5:44 CCD processing done' diff --git a/noao/twodspec/longslit/demos/demos.cl b/noao/twodspec/longslit/demos/demos.cl new file mode 100644 index 00000000..5b065c51 --- /dev/null +++ b/noao/twodspec/longslit/demos/demos.cl @@ -0,0 +1,18 @@ +# DEMOS -- Run specified demo provided a demo file exists. + +procedure demos (demoname) + +file demoname {prompt="Demo name"} + +begin + file demo, demofile + + if ($nargs == 0 && mode != "h") + type ("demos$demos.men") + demo = demoname + demofile = "demos$" // demo // ".cl" + if (access (demofile)) + cl (< demofile) + else + error (1, "Unknown demo " // demo) +end diff --git a/noao/twodspec/longslit/demos/demos.men b/noao/twodspec/longslit/demos/demos.men new file mode 100644 index 00000000..559bc1ae --- /dev/null +++ b/noao/twodspec/longslit/demos/demos.men @@ -0,0 +1,4 @@ + MENU of LONGSLIT Demonstrations + + test - Test of LONGSLIT package (no comments, no delays) + testt - Test of LONGSLIT package with transposed data diff --git a/noao/twodspec/longslit/demos/demos.par b/noao/twodspec/longslit/demos/demos.par new file mode 100644 index 00000000..4181ed59 --- /dev/null +++ b/noao/twodspec/longslit/demos/demos.par @@ -0,0 +1,2 @@ +demoname,f,a,"",,,"Demo name" +mode,s,h,"ql",,, diff --git a/noao/twodspec/longslit/demos/demostd.dat b/noao/twodspec/longslit/demos/demostd.dat new file mode 100644 index 00000000..78f3b9ad --- /dev/null +++ b/noao/twodspec/longslit/demos/demostd.dat @@ -0,0 +1,37 @@ + OBJECT = 'V640Mon 4500 ' / object name + OBSERVAT= 'KPNO ' / observatory + OBSERVER= 'Massey ' / observers + COMMENTS= 'Final New Ice ' / comments + EXPTIME = 1200. / actual integration time + DARKTIME= 1200. / total elapsed time + IMAGETYP= 'object ' / object, dark, bias, etc. + DATE-OBS= '26/11/91 ' / date (dd/mm/yy) of obs. + UT = '12:19:55.00 ' / universal time + ST = '09:13:15.00 ' / sidereal time + RA = '06:37:02.00 ' / right ascension + DEC = '06:08:52.00 ' / declination + EPOCH = 1991.9 / epoch of ra and dec + ZD = '44.580 ' / zenith distance + AIRMASS = 0. / airmass + TELESCOP= 'kpcdf ' / telescope name + DETECTOR= 'te1k ' / detector + PREFLASH= 0 / preflash time, seconds + GAIN = 5.4 / gain, electrons per adu + DWELL = 5 / sample integration time + RDNOISE = 3.5 / read noise, electrons per adu + DELAY0 = 0 / time delay after each pixel + DELAY1 = 0 / time delay after each row + CAMTEMP = -111 / camera temperature + DEWTEMP = -183 / dewar temperature + CCDSEC = '[97:134,2:1023]' / orientation to full frame + ORIGSEC = '[1:1024,1:1024] ' / original size full frame + CCDSUM = '1 1 ' / on chip summation + INSTRUME= 'test ' / instrument + APERTURE= '250micron slit ' / aperture + TVFILT = '4-96 ' / tv filter + DISPAXIS= '2 ' / dispersion axis + GRATPOS = 4624.3 / grating position + TRIM = 'Nov 26 5:44 Trim data section is [23:60,2:1023]' + OVERSCAN= 'Nov 26 5:44 Overscan section is [103:133,2:1023] with mean=611.1 + ZEROCOR = 'Nov 26 5:44 Zero level correction image is Zerof' + CCDPROC = 'Nov 26 5:44 CCD processing done' diff --git a/noao/twodspec/longslit/demos/mktest.cl b/noao/twodspec/longslit/demos/mktest.cl new file mode 100644 index 00000000..e1c5f069 --- /dev/null +++ b/noao/twodspec/longslit/demos/mktest.cl @@ -0,0 +1,31 @@ +# Create demo data if needed. + +artdata +artdata.nxc = 5 +artdata.nyc = 5 +artdata.nxsub = 10 +artdata.nysub = 10 +artdata.nxgsub = 5 +artdata.nygsub = 5 +artdata.dynrange = 100000. +artdata.psfrange = 10. +artdata.ranbuf = 0 + +mkexample ("longslit", "Demoflat", oseed=4, nseed=3, + errors=no, verbose=yes, list=no) +mkheader ("Demoflat", "demos$demoflat.dat", append=no, verbose=no) +mkexample ("longslit", "Demoarc1", oseed=5, nseed=1, + errors=no, verbose=yes, list=no) +mkheader ("Demoarc1", "demos$demoarc1.dat", append=no, verbose=no) +mkexample ("longslit", "Demoobj", oseed=1, nseed=1, + errors=no, verbose=yes, list=no) +mkheader ("Demoobj", "demos$demoobj.dat", append=no, verbose=no) +mkexample ("longslit", "Demostd", oseed=2, nseed=2, + errors=no, verbose=yes, list=no) +mkheader ("Demostd", "demos$demostd.dat", append=no, verbose=no) +mkexample ("longslit", "Demoarc2", oseed=5, nseed=2, + errors=no, verbose=yes, list=no) +mkheader ("Demoarc2", "demos$demoarc2.dat", append=no, verbose=no) +imcopy ("Demoflat,Demoarc1,Demoobj,Demostd,Demoarc2", + "demoflat,demoarc1,demoobj,demostd,demoarc2", + verbose=yes) diff --git a/noao/twodspec/longslit/demos/mktestt.cl b/noao/twodspec/longslit/demos/mktestt.cl new file mode 100644 index 00000000..a60d8ad7 --- /dev/null +++ b/noao/twodspec/longslit/demos/mktestt.cl @@ -0,0 +1,38 @@ +# Create demo data if needed. + +artdata +artdata.nxc = 5 +artdata.nyc = 5 +artdata.nxsub = 10 +artdata.nysub = 10 +artdata.nxgsub = 5 +artdata.nygsub = 5 +artdata.dynrange = 100000. +artdata.psfrange = 10. +artdata.ranbuf = 0 + +mkexample ("longslit", "Demoflat", oseed=4, nseed=3, + errors=no, verbose=yes, list=no) +mkheader ("Demoflat", "demos$demoflat.dat", append=no, verbose=no) +mkexample ("longslit", "Demoarc1", oseed=5, nseed=1, + errors=no, verbose=yes, list=no) +mkheader ("Demoarc1", "demos$demoarc1.dat", append=no, verbose=no) +mkexample ("longslit", "Demoobj", oseed=1, nseed=1, + errors=no, verbose=yes, list=no) +mkheader ("Demoobj", "demos$demoobj.dat", append=no, verbose=no) +mkexample ("longslit", "Demostd", oseed=2, nseed=2, + errors=no, verbose=yes, list=no) +mkheader ("Demostd", "demos$demostd.dat", append=no, verbose=no) +mkexample ("longslit", "Demoarc2", oseed=5, nseed=2, + errors=no, verbose=yes, list=no) +mkheader ("Demoarc2", "demos$demoarc2.dat", append=no, verbose=no) + +print ("Transposing images...") +imtranspose ("Demoflat,Demoarc1,Demoobj,Demostd,Demoarc2", + "demoflat,demoarc1,demoobj,demostd,demoarc2") +wcsreset ("demoflat,demoarc1,demoobj,demostd,demoarc2", wcs="physical", + verbose=no) +hedit ("demoflat,demoarc1,demoobj,demostd,demoarc2", "dispaxis", 1, + update=yes, verify=no, show=no) +imtranspose ("demoflat,demoarc1,demoobj,demostd,demoarc2", + "demoflat,demoarc1,demoobj,demostd,demoarc2") diff --git a/noao/twodspec/longslit/demos/test.cl b/noao/twodspec/longslit/demos/test.cl new file mode 100644 index 00000000..99dbeb77 --- /dev/null +++ b/noao/twodspec/longslit/demos/test.cl @@ -0,0 +1,21 @@ +# Create demo data if needed. + +unlearn background calibrate identify illumination reidentify response +unlearn sensfunc setairmass setjd splot standard fitcoords transform +imdel demo*.imh +cl (< "demos$mktest.cl") +delete demolist,demodelfile,demologfile,demoplotfile,demostdfile v- >& dev$null +if (access ("database")) + delete database/* v- >& dev$null +; +reidentify.logfile="demologfile" +fitcoords.deletions="demodelfile" +fitcoords.logfiles="STDOUT,demologfile" +fitcoords.plotfile="demoplotfile" +transform.logfiles="STDOUT,demologfile" + +# Execute playback. +if (substr (envget("stdgraph"), 1, 6) == "xgterm") + stty (playback="demos$xgtest.dat", nlines=24, verify=no, delay=0) +else + error (1, "Playback for current terminal type not available") diff --git a/noao/twodspec/longslit/demos/testt.cl b/noao/twodspec/longslit/demos/testt.cl new file mode 100644 index 00000000..94dcf0e0 --- /dev/null +++ b/noao/twodspec/longslit/demos/testt.cl @@ -0,0 +1,21 @@ +# Create demo data if needed. + +unlearn background calibrate identify illumination reidentify response +unlearn sensfunc setairmass setjd splot standard fitcoords transform +imdel demo*.imh +cl (< "demos$mktestt.cl") +delete demolist,demodelfile,demologfile,demoplotfile,demostdfile v- >& dev$null +if (access ("database")) + delete database/* v- >& dev$null +; +reidentify.logfile="demologfile" +fitcoords.deletions="demodelfile" +fitcoords.logfiles="STDOUT,demologfile" +fitcoords.plotfile="demoplotfile" +transform.logfiles="STDOUT,demologfile" + +# Execute playback. +if (substr (envget("stdgraph"), 1, 6) == "xgterm") + stty (playback="demos$xgtest.dat", nlines=24, verify=no, delay=0) +else + error (1, "Playback for current terminal type not available") diff --git a/noao/twodspec/longslit/demos/xgtest.dat b/noao/twodspec/longslit/demos/xgtest.dat new file mode 100644 index 00000000..c521337d --- /dev/null +++ b/noao/twodspec/longslit/demos/xgtest.dat @@ -0,0 +1,96 @@ +\O=NOAO/IRAF V2.10EXPORT valdes@puppis Thu 09:50:51 04-Feb-93 +\T=xgtermc +\G=xgtermc +imred\n +bias\n +sections\sdemoobj,demostd,demoarc1,demoarc2\s>\sdemolist\n +colbias\sdemoflat,@demolist\sdemoflat,@demolist\sbias=[100,*]\strim=[20:80,*]\n +\n +:/<-5\s\s\s\s/=(.\s=\r f\scheb\r +f/<-5\s\s\s\s/=(.\s=\r +q/<-5\s\s\s\s/=(.\s=\r +N\n +bye\n +bye\n +response\sdemoflat\sdemoflat[20:40,*]\sdemoflat\n +\n +k/<-5\s\s\s\s/=(.\s=\r +q/<-5\s\s\s\s/=(.\s=\r +imarith\s@demolist\s/\sdemoflat\s@demolist\n +illum\sdemostd\sdemoillum\sbins=1\n +\n +q/<-5\s\s\s\s/=(.\s=\r +\n +:/<-5\s\s\s\s/=(.\s=\r sample\s5:24,36:55\r +:/<-5\s\s\s\s/=(.\s=\r f\scheb\r +:/<-5\s\s\s\s/=(.\s=\r o\s3\r +f/<-5\s\s\s\s/=(.\s=\r +q/<-5\s\s\s\s/=(.\s=\r +imarith\s@demolist\s/\sdemoillum\s@demolist\n +iden\sdemoarc1\ssec="mid\scol"\n +i/<-5\s\s\s\s/=(.\s=\r +m*),'\s\s\s\s*)&/=2\r 5015\r +m;$,9\s\s\s\s;%+/%*\r 7281\r +l/<-5\s\s\s\s/=(.\s=\r +f/<-5\s\s\s\s/=(.\s=\r +d%"5!\s\s\s\s%!;$**\r +d:7'5\s\s\s\s:845=(\r +f/<-5\s\s\s\s/=(.\s=\r +l/<-5\s\s\s\s/=(.\s=\r +d/0%>\s\s\s\s/008&"\r +f/<-5\s\s\s\s/=(.\s=\r +q/<-5\s\s\s\s/=(.\s=\r +q/<-5\s\s\s\s/=(.\s=\r +\n +reid\sdemoarc1\sdemoarc1,demoarc2\ssec="mid\scol"\snlost=5\sv+\n +iden\sdemostd\ssec="mid\sline"\n +m/<-;\s\s\s\s/=(-94\r 50\r +q/<-5\s\s\s\s/=(.\s=\r +\n +reid\sdemostd\sdemostd\ssec="mid\sline"\snlost=5\sv+\n +fitcoords\scombine+\sfitname=demoarcfit\n +demoarc1,demoarc2\n +\n +y/<-5\s\s\s\s/=(.\s=\r +x/<-5\s\s\s\s/=(.\s=\r +r/<-5\s\s\s\s/=(.\s=\r +q/<-5\s\s\s\s/=(.\s=\r +\n +fitcoords\n +demostd\n +\n +y/<-5\s\s\s\s/=(.\s=\r +x/<-5\s\s\s\s/=(.\s=\r +r/<-5\s\s\s\s/=(.\s=\r +q/<-5\s\s\s\s/=(.\s=\r +\n +transform\slogfiles=STDOUT,demologfile\n +demoobj,demostd\n +demoobj,demostd\n +demoarcfit,demostd\n +background\sdemoobj,demostd\sdemoobj,demostd\n +256\r +:/<-5\s\s\s\s/=(.\s=\r sample\s5:24,36:55\r +:/<-5\s\s\s\s/=(.\s=\r nav\s-20\r +f/<-5\s\s\s\s/=(.\s=\r +q/<-5\s\s\s\s/=(.\s=\r +\r +256\r +q/<-5\s\s\s\s/=(.\s=\r +\r +nsum=7\n +setairmass\sdemoobj,demostd\n +standard\sdemostd\sdemostdfile\sap=31\n +hz14\n +n\n +sensfunc\sdemostdfile\sdemosens\slogfile=demologfile\n +\n +q/<-5\s\s\s\s/=(.\s=\r +calibrate\sdemoobj,demostd\sdemoobj,demostd\ssens=demosens\n +splot\sdemostd,demoobj\n +31\n +y/<-5\s\s\s\s/=(.\s=\r hz14\r +q/<-5\s\s\s\s/=(.\s=\r +o/<-5\s\s\s\s/=(.\s=\r +#/<-5\s\s\s\s/=(.\s=\r 1\r +q/<-5\s\s\s\s/=(.\s=\r diff --git a/noao/twodspec/longslit/demos/xgtestold.dat b/noao/twodspec/longslit/demos/xgtestold.dat new file mode 100644 index 00000000..071fa083 --- /dev/null +++ b/noao/twodspec/longslit/demos/xgtestold.dat @@ -0,0 +1,93 @@ +\O=NOAO/IRAF V2.10EXPORT valdes@puppis Thu 09:50:51 04-Feb-93 +\T=xgtermc +\G=xgtermc +imred\n +bias\n +sections\sdemoobj,demostd,demoarc1,demoarc2\s>\sdemolist\n +colbias\sdemoflat,@demolist\sdemoflat,@demolist\sbias=[100,*]\strim=[20:80,*]\n +\n +:*'3,\r f\scheb\r +f*'3,\r +q*'3,\r +N\n +bye\n +bye\n +response\sdemoflat\sdemoflat[20:40,*]\sdemoflat\n +\n +k*'3,\r +q*'3,\r +imarith\s@demolist\s/\sdemoflat\s@demolist\n +illum\sdemostd\sdemoillum\sbins=1\n +\n +q*'3,\r +\n +:*'3,\r sample\s5:24,36:55\r +:*'3,\r f\scheb\r +:*'3,\r o\s3\r +f*'3,\r +q*'3,\r +imarith\s@demolist\s/\sdemoillum\s@demolist\n +iden\sdemoarc1\ssec="mid\scol"\n +m*)4)\r 5015\r +m;$4)\r 7281\r +l*'3,\r +f*'3,\r +d$<5!\r +d/9&5\r +f*'3,\r +l*'3,\r +q*'3,\r +q*'3,\r +\n +reid\sdemoarc1\sdemoarc1,demoarc2\ssec="mid\scol"\sv+\n +iden\sdemostd\ssec="mid\sline"\n +m0\s4"\r 50\r +q0\s4"\r +\n +reid\sdemostd\sdemostd\ssec="mid\sline"\sv+\n +fitcoords\scombine+\sfitname=demoarcfit\n +demoarc1,demoarc2\n +\n +y*'3,\r +x*'3,\r +r*'3,\r +q*'3,\r +\n +fitcoords\n +demostd\n +\n +y*'3,\r +x*'3,\r +r*'3,\r +q*'3,\r +\n +transform\slogfiles=STDOUT,demologfile\n +demoobj,demostd\n +demoobj,demostd\n +demoarcfit,demostd\n +background\sdemoobj,demostd\sdemoobj,demostd\n +256\r +:*'3,\r sample\s5:24,36:55\r +:*'3,\r nav\s-20\r +f*'3,\r +q*'3,\r +\r +256\r +q*'3,\r +\r +nsum=7\n +setairmass\sdemoobj,demostd\n +standard\sdemostd\sdemostdfile\sap=31\n +hz14\n +n\n +sensfunc\sdemostdfile\sdemosens\slogfile=demologfile\n +\n +q*'3,\r +calibrate\sdemoobj,demostd\sdemoobj,demostd\ssens=demosens\n +splot\sdemostd,demoobj\n +31\n +y*'3,\r hz14\r +q*'3,\r +o*'3,\r +#*'3,\r 1\r +q*'3,\r diff --git a/noao/twodspec/longslit/doc/extinction.hlp b/noao/twodspec/longslit/doc/extinction.hlp new file mode 100644 index 00000000..39579a07 --- /dev/null +++ b/noao/twodspec/longslit/doc/extinction.hlp @@ -0,0 +1,87 @@ +.help extinction May87 noao.twodspec.longslit +.ih +NAME +extinction -- Apply atmospheric extinction corrections +.ih +USAGE +extinction images +.ih +PARAMETERS +.ls input +List of input images to be extinction corrected. +.le +.ls output +List of output extinction corrected images. Output images may be the +same as the input images. +.le +.ls extinction = "onedstds$kpnoextinct.dat" +Extinction file to be used. The standard extinction files: + +.nf + onedstds$kpnoextinct.dat - KPNO standard extinction + onedstds$ctioextinct.dat - CTIO standard extinction +.fi +.le +.ih +DESCRIPTION +The specified images are corrected for atmospheric extinction according +to the formula + + correction factor = 10 ** (0.4 * airmass * extinction) + +where the extinction is a tabulated function of the wavelength. The +extinction file contains lines of wavelength and extinction at that +wavelength. The units of the wavelength must be the same as those of +the dispersion corrected images; i.e. Angstroms. If the image is +dispersion corrected in logarithmic wavelength intervals (DC-FLAG = 1) +the task will convert to wavelength and so the extinction file must +still be wavelength. The table values are interpolated +to the wavelengths of the image pixels and the correction applied to +the pixel values. Note that the image pixel values are modifed. + +The airmass is sought in the image header under the name AIRMASS. If the +airmass is not found then it is computed from the zenith distance (ZD in hours) +using the approximation formula from Allen's "Astrophysical Quantities", 1973, +page125 and page 133 + + AIRMASS = sqrt (cos (ZD) ** 2 + 2 * scale + 1) + +where the atmospheric scale height is set to be 750. If the parameter ZD +is not found then it must be computed from the hour angle (HA in hours), +the declination (DEC in degrees), and the observation latitude (LATITUDE +in degress). The hour angle may be computed from the right ascension +(RA in hours) and siderial time (ST in hours). Computed quantities are +recorded in the image header. Flags indicating extinction correction are +also set in the image header. + +The image header keyword DISPAXIS must be present with a value of 1 for +dispersion parallel to the lines (varying with the column coordinate) or 2 +for dispersion parallel to the columns (varying with line coordinate). +This parameter may be added using \fBhedit\fR. Note that if the image has +been transposed (\fBimtranspose\fR) the dispersion axis should still refer +to the original dispersion axis unless the physical world coordinate system +is first reset (see \fBwcsreset\R). This is done in order to allow images +which have DISPAXIS defined prior to transposing to still work correctly +without requiring this keyword to be changed. +.ih +EXAMPLES +1. A set of dispersion corrected images is extinction corrected in-place as +follows: + +.nf + cl> extinction img* img* +.fi + +2. To keep the uncorrected image: + +.nf + cl> extinction nite1.004 nite1ext.004 +.fi + +3. If the DISPAXIS keyword is missing and the dispersion is running +vertically (varying with the image lines): + +.nf + cl> hedit *.imh dispaxis 2 add+ +.fi +.endhelp diff --git a/noao/twodspec/longslit/doc/fccoeffs b/noao/twodspec/longslit/doc/fccoeffs new file mode 100644 index 00000000..ab8de92f --- /dev/null +++ b/noao/twodspec/longslit/doc/fccoeffs @@ -0,0 +1,210 @@ +From davis Tue May 18 15:09:59 1993 +Received: by tucana.tuc.noao.edu (4.1/SAG.tucana.12) + id AA26431; Tue, 18 May 93 15:09:56 MST; for sites +Date: Tue, 18 May 93 15:09:56 MST +From: davis (Lindsey Davis) +Message-Id: <9305182209.AA26431@tucana.tuc.noao.edu> +To: belkine@mesiob.obspm.circe.fr +Subject: RE: geomap +Cc: sites + + + +Igor, + + The following is a copy of a mail message I sent to another user who made +the same request regarding geomap. I hope this is of use to you. + + + Lindsey Davis + +############################################################################### + + + Jeannette forwarded your request for a detailed description of the +geomap output format to me. This format was originally intended to be +for the internal use of geomap only, but the following should help you +decode it. + + 1. For simple linear geometric transformations you will see the +following two entries in the fit record. Surface1 describes the linear +portion of the fit; surface2 describes the residual distortion map +which is always 0 for linear fits. + + surface1 11 + surface(xfit) surface(yfit) (surface type 1=cheb, 2=leg, 3=poly) + xxorder(xfit) yxorder(yfit) (always 2) + xyorder(xfit) yyorder(yfit) (always 2) + xxterms(xfit) yxterms(yfit) (always 0) + xmin(xfit) xmin(yfit) (geomap input or data) + xmax(xfit) xmax(yfit) (geomap input or data) + ymin(xfit) ymin(yfit) (geomap input or data) + ymax(xfit) ymax(yfit) (geomap input or data) + a d + b e + c f + surface2 0 + +This above describes the following linear surfaces. + + xfit = a + b * x + c * y (polynomial) + yfit = d + e * x + f * y + + xfit = a + b * xnorm + c * ynorm (chebyshev) + yfit = d + e * xnorm + f * ynorm + + xfit = a + b * xnorm + c * ynorm (legendre) + yfit = d + e * xnorm + f * ynorm + + xnorm = (2 * x - (xmax + xmin)) / (xmax - xmin) + ynorm = (2 * y - (ymax + ymin)) / (ymax - ymin) + +Xnorm and ynorm are the input x and y values normalized between -1.0 +and 1.0. + + + + + 2. For a higher order fit, say xorder=4 yorder=4 and xterms=yes, +the format is more complicated. The second surface is computed by fitting +the higher order surface to the residuals of the first fit. The geomap +output will look something like the following. + + surface1 11 + surface(xfit) surface(yfit) (surface type 1=cheb, 2=leg, 3=poly) + xxorder(xfit) yxorder(yfit) (always 2) + xyorder(xfit) yyorder(yfit) (always 2) + xxterms(xfit) yxterms(yfit) (always 0) + xmin(xfit) xmin(yfit) (geomap input or data) + xmax(xfit) xmax(yfit) (geomap input or data) + ymin(xfit) ymin(yfit) (geomap input or data) + ymax(xfit) ymax(yfit) (geomap input or data) + a d + b e + c f + surface2 24 + surface(xfit) surface(yfit) (surface type 1=cheb, 2=leg, 3=poly) + xxorder(xfit) yxorder(yfit) (4) + xyorder(xfit) yyorder(yfit) (4) + xxterms(xfit) yxterms(yfit) (1 in this case) + xmin(xfit) xmin(yfit) (geomap input or data) + xmax(xfit) xmax(yfit) (geomap input or data) + ymin(xfit) ymin(yfit) (geomap input or data) + ymax(xfit) ymax(yfit) (geomap input or data) + C00(xfit) C00(yfit) + C10(xfit) C10(yfit) + C20(xfit) C20(yfit) + C30(xfit) C30(yfit) + C01(xfit) C01(yfit) + C11(xfit) C11(yfit) + C21(xfit) C21(yfit) + C31(xfit) C31(yfit) + C02(xfit) C02(yfit) + C12(xfit) C12(yfit) + C22(xfit) C22(yfit) + C32(xfit) C32(yfit) + C03(xfit) C03(yfit) + C13(xfit) C13(yfit) + C23(xfit) C23(yfit) + C33(xfit) C33(yfit) + + +where the Cmn are the coefficients of the polynomials Pmn, and the Pmn +are defined as follows + + Pmn = x ** m * y ** n (polynomial) + + Pmn = Pm(xnorm) * Pn(ynorm) (chebyshev) + + P0(xnorm) = 1.0 + P1(xnorm) = xnorm + Pm+1(xnorm) = 2.0 * xnorm * Pm(xnorm) - Pm-1(xnorm) + xnorm = (2 * x - (xmax + xmin)) / (xmax - xmin) + + P0(ynorm) = 1.0 + P1(ynorm) = ynorm + Pn+1(ynorm) = 2.0 * ynorm * Pn(ynorm) - Pn-1(ynorm) + ynorm = (2 * y - (ymax + ymin)) / (ymax - ymin) + + Pmn = Pm(xnorm) * Pn(ynorm) (legendgre) + + P0(xnorm) = 1.0 + P1(xnorm) = xnorm + Pm+1(xnorm) = ((2m + 1) * xnorm * Pm(xnorm) - m * Pm-1(xnorm))/ + (m + 1) + xnorm = (2 * x - (xmax + xmin)) / (xmax - xmin) + + P0(ynorm) = 1.0 + P1(ynorm) = ynorm + Pn+1(ynorm) = ((2n + 1) * ynorm * Pn(ynorm) - n * Pn-1(ynorm))/ + (n + 1) + ynorm = (2 * y - (ymax + ymin)) / (ymax - ymin) + + +Hopefully I have copied this all down correctly. The main points to remember +is that the mangitudes of the coefficients reflect both the function type +(polynomial, chebyshev, or legendre) and the normalization (xmin, xmax, +ymin, ymax). + + Hope this helps you out and write back if you have more questions. + + Lindsey Davis + +======================================= + +# <Date> +begin <name> + task fitcoords + axis 1 # Axis of fitted value + surface 24 # The number of following parameters/coefficients + surface # surface type 1=chebyshev, 2=legendre + xorder # X order + yorder # Y order + xterms # Cross terms? 0=no, 1=yes (always 1 for fitcoords) + xmin # Minimum x value in fit - usually 1 + xmax # Maximum x value in fit - usually image dimension + ymin # Minimum y value in fit - usually 1 + ymax # Maximum y value in fit - usually image dimension + C00 # Coefficients (shown for xorder=4 and yorder=4) + C10 + C20 + C30 + C01 + C11 + C21 + C31 + C02 + C12 + C22 + C32 + C03 + C13 + C23 + C33 + + +The fit is a sum of the form: + + fit = sum(m=0 to xorder-1) sum(n=0 to yorder-1) {Cmn*Pm(x')*Pn(y')} + +where the cross-terms may or may not be included depending on the xterms +parameter. Cross-terms are always used in FITCOORDS. + +The coefficients are defined in terms of normalized independent variables +in the range -1 to 1. If x and y are actual values then the normalized +variables, x' and y', are defined using the data range parameters as: + + x' = (2 * x - (xmax + xmin)) / (xmax - xmin) + y' = (2 * y - (ymax + ymin)) / (ymax - ymin) + +The Pi(z), where z is either x' or y', are defined iteratively as follows: + + # Chebyshev + P0(z) = 1.0 + P1(z) = z + Pi+1(z) = 2.0 * z * Pi(z) - Pi-1(z) + + # Legendre + P0(z) = 1.0 + P1(z) = z + Pi+1(z) = ((2i + 1) * z * Pi(z) - i * Pi-1(z)) / (i + 1) diff --git a/noao/twodspec/longslit/doc/fceval.hlp b/noao/twodspec/longslit/doc/fceval.hlp new file mode 100644 index 00000000..87d258c0 --- /dev/null +++ b/noao/twodspec/longslit/doc/fceval.hlp @@ -0,0 +1,87 @@ +.help fceval Aug03 noao.twodspec.longslit +.ih +NAME +fceval -- Evaluate coordinates using the FITCOORDS solutions +.ih +USAGE +fceval input output fitnames +.ih +PARAMETERS +.ls input +Input text file of pixel coordinates. This may be "STDIN" to read +coordinates from the terminal or pipe. +.le +.ls output +Output text file of pixel coordinates and fitted coordinates. This may +be "STDOUT" to write coordinates to the terminal or pipe. +.le +.ls fitnames +Names of the user coordinate maps to evaluate. +.le +.ls database = "database" +Database containing the coordinate maps. +.le +.ih +DESCRIPTION +This task transforms pixel coordinates to the world coordinates fit with +FITCOORDS. When there is no map for an axis the identify transform is +used. If there are more the one map for an axis the average of the mapped +coordinates is output. This is the same behavior as TRANSFORM. + +The input file consists of two columns giving the x and y pixel values +in the frame of the untransformed image data. The output is a file +with four columns giving the input x any y pixel values and the +user coordinates fit by FITCOORDS. + +Two typical uses for this task are to look up world coordinates for +points in the untransformed data and to generate transformations using +GEOMAP and GEOTRAN. +.ih +EXAMPLES +1. Evaluate a wavelength and slit position fit where the input pixel coordinates +are entered interactively and the output is written to the terminal. + +.nf + cl> fceval STDIN STDOUT arcfit,std + 1 1 + 1. 1. 20.60425149463117 4202.47202514205 + 60 1 + 60. 1. 79.60425149463118 4203.316616448186 + 1 512 + 1. 512. 19.15606081299484 7356.089801036373 + 60 512 + 60. 512. 78.15606081299485 7355.042495319318 +.fi + +In this case the first axis corresponds to the spatial dimension and +the second to the dispersion dimension. The arcfit was created using +Angstroms and so the units of the last column is Angstroms. + +2. One use of this task is to generate the inverse transformation from +that produced by TRANSFORM. The steps are: 1) produce a grid of +coordinates using LISTPIX and FCEVAL, 2) convert the user coordinates to +pixel coordinates in the transformed data using WCSCTRAN, 3) fit a +transformation using GEOMAP, and 4) transform the data with GEOTRAN. + +.nf + cl> listpix orig[*:5,*:5] wcs=physical verb- | + >>> fceval STDIN STDOUT arcfit,std | + >>> wcsctran STDIN coords trans world logical columns="3 4" + cl> geomap coords geomap.db 1 61 1 512 + cl> geotran trans origNEW geomap.db coords flux+ +.fi + +This example uses pipes to eliminate intermediate files. But these +files can be useful for understanding the process. LIXTPIX is used to +generate a grid of points with some subsampling. Be sure to use "physical" +for the coordinate system otherwise the grid of x and y values will be +for the subsection. The order of the columns will be appropriate for +GEOMAP to compute the inverse transformation. By reversing the order +of the columns one could generate a transformation similar to that +produced by TRANSFORM in order to use features in GEOTRAN not provided +by TRANSFORM. However, the world coordinate system information will +not be automatically set. +.ih +SEE ALSO +fitcoords, transform, geomap, geotran +.endhelp diff --git a/noao/twodspec/longslit/doc/fitcoords.hlp b/noao/twodspec/longslit/doc/fitcoords.hlp new file mode 100644 index 00000000..a376ee74 --- /dev/null +++ b/noao/twodspec/longslit/doc/fitcoords.hlp @@ -0,0 +1,287 @@ +.help fitcoords Apr00 noao.twodspec.longslit +.ih +NAME +fitcoords -- Fit user coordinates to the image coordinates +.ih +USAGE +fitcoords images fitname +.ih +PARAMETERS +.ls images +List of images containing the feature coordinates to be fit. If the +parameter \fIcombine\fR is yes then feature coordinates from all the images +are combined and fit by a single function. Otherwise the feature coordinates +from each image are fit separately. +.le +.ls fitname = "" +If the input images are combined and fit by a single function then the fit +is stored under this name. If the images are not combined then the +fit for each image is stored under the name formed by appending the image +name to this name. A null prefix is acceptable when not combining but it +is an error if combining a list of images. +.le +.ls interactive = yes +Determine coordinate fits interactively? +.le +.ls combine = no +Combine the coordinates from all the input images and fit them by a single +function? If 'no' then fit the coordinates from each image separately. +.le +.ls database = "database" +Database containing the feature coordinate information used in fitting the +coordinates and in which the coordinate fit is recorded. +.le +.ls deletions = "deletions.db" +Deletion list file. If not null then points whose coordinates match those in +this file (if it exists) are initially deleted from the fit. +If the fitting is done interactively then the coordinates of +any deleted points (after exiting from the interactive fitting) are recorded +in this file. +.le +.ls function = "chebyshev" +Type of two dimensional function to use in fitting the user coordinates. +The choices are "chebyshev" polynomial and "legendre" polynomial. +The function may be abbreviated. If the task is interactive then +the user may change the function later. +.le +.ls xorder = 6 +Order of the mapping function along the first image axis. +The order is the number of polynomial terms. If the task is interactive +then the user may change the order later. +.le +.ls yorder = 6 +Order of the mapping function along the second image axis. +The order is the number of polynomial terms. If the task is interactive +then the user may change the order later. +.le +.ls logfiles = "STDOUT,logfile" +List of files in which to keep logs containing information about +the coordinate fit. If null then no log is kept. +.le +.ls plotfile = "plotfile" +Name of file to contain metacode for log plots. If null then no log plots +are kept. When the fitting is interactive the last graph is recorded in +the plot file and when not interactive a default plot is recorded. +.le +.ls graphics = "stdgraph" +Graphics output device. +.le +.ls cursor = "" +Graphics cursor input. If null the standard graphics cursor is used. +.le +.bp +.ih +CURSOR COMMANDS + +.nf +? List commands +c Print data values for point nearest the cursor +d Delete the point or set of points with constant x, y, or z + nearest the cursor (p, x, y, z,) +f Fit surface +l Graph the last set of points (in zoom mode) +n Graph the next set of points (in zoom mode) +p Graph all features +q Quit +r Redraw a graph +u Undelete the point or set of points with constant x, y, or z + nearest the cursor (p, x, y, z,) +w Window the graph. Type '?' to the "window:" prompt for more help. +x Select data for the x axis (x, y, z, s, r) +y Select data for the y axis (x, y, z, s, r) +z Zoom on the set of points with constant x, y, or z (x, y, z) + Unzoom with p + +:corners Show the fitted values for the corners of the image +:function type Set the function for the fitted surface + (chebyshev, legendre) +:show Show the fitting parameters +:xorder value Set the x order for the fitted surface +:yorder value Set the y order for the fitted surface +.fi +.ih +DESCRIPTION +A two dimensional function of the image coordinates is fitted to the user +coordinates from the specified images; + +.nf + user coordinate = function (column, line) + + or + + z = s (x, y) +.fi + +The coordinates from all the input images may be combined in a single fit or +the coordinates from each image may be fit separately. If the +coordinates from the input images are combined then the fitted function +is recorded in the database under the specified name. If +the coordinates are fit separately the fitted function is recorded under +a name formed by appending the image name to the specified root name. + +When the task is interactive the user is first queried whether to perform +the fitting interactively. The user may answer "yes", "no", "YES", or "NO" +to the query. The lowercase responses apply only to the current fit +and the uppercase responses apply to all remaining fits. When the +fitting is done interactively the user may change the fitted function and +orders iteratively, delete individual coordinates or entire features, +and graph the fit and residuals in a number ways. +The CURSOR COMMANDS section describes the graphics cursor keystrokes +which are available. When selecting data for the graph axes the +follow definitions apply: + +.nf + x Input image column positions + y Input image line positions + z Input user coordinates + s Fitted user coordinates + r Residuals (s - z) +.fi + +A very useful feature is zooming, deleting, or undeleting a subset of data +points. The subsets +are defined as points with the same x, y, or z value as the point indicated +by the cursor when typing (z)oom, (d)elete, or (u)ndelete. + +When a satisfactory coordinate fit has been determined exit with the (q)uit +key. The user is asked if the fit is to be recorded in the database. + +If a deletion list file is specified then the coordinates of any +points deleted interactively are recorded in this file. This file then can +be read by subsequent fits to initially delete points with matching +coordinates. This is generally used when fitting a series of images +non-interactively. + +Information about the fitted function may be recorded. Textual information +is written to the specified log files (which may include the standard +output STDOUT). The last interactive plot or a default non-interactive +plot is written the specified plot file which may be examined and spooled +at a later time. + + +FITCOORDS DATABASE + +The FITCOORDS fits are stored in text files in the subdirectory given by +the "database" parameter. The name of the file is fc<fitname> where +<fitname> is the specified fit name. The database text file contains +blocks of lines beginning with a time stamp followed by line with the +"begin" keyword. The value following "begin" is the fit name, which is +often the name of the image used for the fit. If there is more than one +block with the same fit name then the last one is used. + +The "task" keyword will has the value "fitcoords" and the "axis" keyword +identifies the axis to which the surface fit applies. An axis of 1 refers +to the first or x axis (the first dimension of the image) and 2 refers to +the second or y axis. + +The "surface" keyword specifies the number of coefficients for the surface +fit given in the following lines . The surface fit is produced by an IRAF +math package called "gsurfit". The coefficients recorded in the database +are intented to be internal to that package. However the following +describes how to interpret the coefficients. + +The first 8 lines specify: + +.nf + function - Function type (1=chebyshev, 2=legendre) + xorder - X "order" (highest power of x) + yorder - Y "order" (highest power of y) + xterms - Cross-term type (always 1 for FITCOORDS) + xmin - Minimum x over which the fit is defined + xmax - Maximum x over which the fit is defined + ymin - Minimum y over which the fit is defined + ymax - Maximum y over which the fit is defined +.fi + +The polynomial coefficients follow in array order with the x index +varying fastest: + +.nf + C00 + C10 + C20 + ... + C<xorder-1>0 + C01 + C11 + C21 + ... + C<xorder-1>1 + ... + C<xorder-1><yorder-1> +.fi + +The surface fitting functions have the form + +.nf + fit(x,y) = Cmn * Pmn +.fi + +where the Cmn are the coefficients of the polynomials terms Pmn, and the Pmn +are defined as follows: + +.nf +Chebyshev: Pmn = Pm(xnorm) * Pn(ynorm) + + xnorm = (2 * x - (xmax + xmin)) / (xmax - xmin) + ynorm = (2 * y - (ymax + ymin)) / (ymax - ymin) + + P0(xnorm) = 1.0 + P1(xnorm) = xnorm + Pm+1(xnorm) = 2.0 * xnorm * Pm(xnorm) - Pm-1(xnorm) + + P0(ynorm) = 1.0 + P1(ynorm) = ynorm + Pn+1(ynorm) = 2.0 * ynorm * Pn(ynorm) - Pn-1(ynorm) + +Legendre: Pmn = Pm(xnorm) * Pn(ynorm) + + xnorm = (2 * x - (xmax + xmin)) / (xmax - xmin) + ynorm = (2 * y - (ymax + ymin)) / (ymax - ymin) + + P0(xnorm) = 1.0 + P1(xnorm) = xnorm + Pm+1(xnorm) = ((2m+1)*xnorm*Pm(xnorm)-m*Pm-1(xnorm))/(m+1) + + P0(ynorm) = 1.0 + P1(ynorm) = ynorm + Pn+1(ynorm) = ((2n+1)*ynorm*Pn(ynorm)-n*Pn-1(ynorm))/(n+1) +.fi + +Notice that the x and y values are first normalized to the interval -1 to 1 +over the range of the surface as given by the xmin, xmax, ymin, and ymax +elements of the database description. +.ih +EXAMPLES +A number of strong arc lines are identified along one column of an arc +calibration image "arc001". The arc lines are then reidentified at every +20th column. A two dimensional dispersion solution is determined as follows: + + cl> fitcoords arc001 fit. + +The fitting is done interactively and deleted points are recorded. +The fit is recorded under the name fit.arc001. A set of similar arc +calibrations are fit non-interactively, with the same points deleted, +as follows: + + cl> fitcoords arc* interactive=no + +Several stellar spectra are identified at different positions along the slit +and traced to other lines. A fit to the geometric distortion is determined +with the command: + + cl> fitcoords star001,star003,star005 fitname=distortion combine=yes + +In this case the coordinates from all the tracings are combined in a single +fit called distortion. + +The plots in the plot file are spooled to the standard plotting device as +follows: + + cl> gkimosaic plotfile + +\fBGkimosaic\fR is in the \fBplot\fR package. +.ih +SEE ALSO +transform +.endhelp diff --git a/noao/twodspec/longslit/doc/fluxcalib.hlp b/noao/twodspec/longslit/doc/fluxcalib.hlp new file mode 100644 index 00000000..ee38cee5 --- /dev/null +++ b/noao/twodspec/longslit/doc/fluxcalib.hlp @@ -0,0 +1,106 @@ +.help fluxcalib Oct86 noao.twodspec.longslit +.ih +NAME +fluxcalib -- Apply flux calibration +.ih +USAGE +fluxcalib images fluxfile +.ih +PARAMETERS +.ls input +List of input images to be flux calibrated. +.le +.ls output +List of output flux calibrated images. The output images may be the same +as the input images. The output image will be of type real regardless +of the input pixel type. +.le +.ls fluxfile +Flux calibration file from \fBonedspec.sensfunc\fR. +.le +.ls fnu = no +Convert the flux calibration to flux per unit frequency (F-nu)? +.le +.ls exposure = "otime" +Exposure time keyword in image headers. +.le +.ih +DESCRIPTION +The specified images are flux calibrated using a flux calibration image +file derived from the \fBonedspec\fR package using standard stars. +The flux calibration pixel values are in magnitudes and the pixel coordinates +are in wavelength. The multiplicative calibration factor is given by the +formula + + factor = 10 ** (-0.4 * calibration) / exposure / dispersion. + +Since the calibration data has units of (instrumental intensity) / +(ergs/cm**2), the exposure time for the image must be in seconds and the +pixel dispersion in wavelength/pixel to yield units of +ergs/cm**2/sec/wavelength. + +The calibration wavelengths are interpolated to the wavelengths +of the image pixels and the correction applied to the pixel values. +Note that the image pixel values are modified. + +If flux per unit frequency is requested then the flux values are multiplied +by + + wavelength ** 2 / velocity of light (in Angstroms/sec) + +to yield units of ergs/cm**2/Hz/sec/(wavelength/Angstrom). Note that normally +the wavelength units should be Angstroms. + +It is possible to flux calibrate images which are binned in logarithmic +wavelength intervals. The point to note is that the units of the flux +calibrated image will be the same. Therefore, rebinning to linear +wavelength coordinates requires only interpolation and not flux conservation. +When extracting standard stars from logarithmicaly bin spectra for determination +of a flux calibration it is necessary to rebin the extracted one dimensional +spectra to linear wavelength (required by \fBonedspec\fR) conserving +flux so that the instrumental counts are preserved. + +The image header keyword DISPAXIS must be present with a value of 1 for +dispersion parallel to the lines (varying with the column coordinate) or 2 +for dispersion parallel to the columns (varying with line coordinate). +This parameter may be added using \fBhedit\fR. Note that if the image has +been transposed (\fBimtranspose\fR) the dispersion axis should still refer +to the original dispersion axis unless the physical world coordinate system +is first reset (see \fBwcsreset\R). This is done in order to allow images +which have DISPAXIS defined prior to transposing to still work correctly +without requiring this keyword to be changed. +.ih +EXAMPLES +Standard stars were observed and extracted to one dimensional spectra. +The standard stars are then used to determine a flux calibration using +the \fBonedspec\fR package. A set of dispersion and extinction corrected +images is flux calibrated in-place with the command + +.nf + cl> fluxcalib img* img* sens.0000 +.fi + +where "sens.0000" is the calibration file produced by the task +\fBonedspec.sensfunc\fR. + +To keep the uncalibrated image: + +.nf + cl> fluxcalib n1ext.004 n1extf.004 sens.0000 +.fi + +3. If the DISPAXIS keyword is missing and the dispersion is running +vertically (varying with the image lines): + +.nf + cl> hedit *.imh dispaxis 2 add+ +.fi +.ih +REVISIONS +.ls FLUXCALIB V2.10 +The output pixel type is now forced to be real. +.le +.ih +SEE ALSO +onedspec.standard onedspec.sensfunc +.endhelp diff --git a/noao/twodspec/longslit/doc/illumination.hlp b/noao/twodspec/longslit/doc/illumination.hlp new file mode 100644 index 00000000..5697bfad --- /dev/null +++ b/noao/twodspec/longslit/doc/illumination.hlp @@ -0,0 +1,220 @@ +.help iillumination Jul86 noao.twodspec.longslit +.ih +NAME +iillumination -- Determine iillumination calibrations +.ih +USAGE +iillumination images iilluminations +.ih +PARAMETERS +.ls images +Images to use in determining iillumination calibrations. These are +generally sky spectra. An image section may be used to select only a +portion of the image. +.le +.ls iilluminations +Iillumination calibration images to be created. Each iillumination image is +paired with a calibration image. If the image exists then it will be modified +otherwise it is created. +.le +.ls interactive = yes +Graph the average spectrum and select the dispersion bins +and graph and fit the slit profile for each dispersion bin interactively? +.le +.ls bins = "" +Range string defining the dispersions bins within which the slit profiles +are determined. If the range string is null then the dispersion +bins are determined by the parameter \fInbins\fR. +.le +.ls nbins = 5 +If the dispersion bins are not specified explicitly by the parameter +\fIbins\fR then the dispersion range is divided into this number of +nearly equal bins. +.le +.ls sample = "*" +Sample of points to use in fitting each slit profile. +The sample is selected with a range string. +.le +.ls naverage = 1 +Number of sample points to average or median before fitting a function. +If the number is positive the average of each set of naverage sample +points is formed while if the number is negative then the median of each set +of points (in absolute value) is formed. This subsample of points is +used in fitting the slit profile. +.le +.ls function = "spline3" +Function to fit to each dispersion bin to form the iillumination function. +The options are "spline1", "spline3", "legendre", and "chebyshev". +.le +.ls order = 1 +Order of the fitting function or the number of spline pieces. +.le +.ls low_reject = 0., high_reject = 0. +Rejection limits below and above the fit in units of the residual sigma. +.le +.ls niterate = 1 +Number of rejection iterations. +.le +.ls grow = 0 +Reject additional points within this distance of points exceeding the +rejection threshold. +.le +.ls interpolator = "poly3" +Interpolation type. One of "nearest", "linear", "poly3", "poly5", or +"spline3". +.le +.ls graphics = "stdgraph" +Graphics output device. May be one of the standard devices "stdgraph", +"stdplot", or "stdvdm" or an explicit device. +.le +.ls cursor = "" +Graphics input device. May be either null for the standard graphics cursor +or a file containing cursor commands. +.le +.ih +CURSOR KEYS +The interactive curve fitting package \fBicfit\fR is used to fit a function +to the average calibration spectrum. Additional help on using this package +and the cursor keys is available under the name "icfit". + +When the dispersion bins are set graphically the following cursor keys are +defined. + +.ls ? +Clear the screen and print a menu of the cursor options. +.le +.ls i +Initialize the sample ranges. +.le +.ls q +Exit interactive dispersion bin selection. +.le +.ls s +Set a bin with the cursor. This may be repeated any number of times. +Two keystrokes are required to mark the two ends of the bin. +.le + +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. + +.nf +:bins value Iillumination bins +:show Show the values of all the parameters +.fi +.ih +DESCRIPTION +An iillumination calibration, in the form of an image, is created for each +longslit calibration image, normally a sky spectrum. The iillumination +calibration is determined by fitting functions across the slit (the slit +profiles) at a number of points along the dispersion, normalizing each fitted +function to unity at the center of the slit, and interpolating the iillumination +between the dispersion points. The fitted data is formed by dividing the +dispersion points into a set of bins and averaging the slit profiles within +each bin. The interpolation type is a user parameter. + +The image header keyword DISPAXIS must be present with a value of 1 for +dispersion parallel to the lines (varying with the column coordinate) or 2 +for dispersion parallel to the columns (varying with line coordinate). +This parameter may be added using \fBhedit\fR. Note that if the image has +been transposed (\fBimtranspose\fR) the dispersion axis should still refer +to the original dispersion axis unless the physical world coordinate system +is first reset (see \fBwcsreset\fR). This is done in order to allow images +which have DISPAXIS defined prior to transposing to still work correctly +without requiring this keyword to be changed. + +If the output image does not exist it is first created with unit iillumination +everywhere. Subsequently the iillumination is only modified in those regions +occupied by the input image. Thus, an image section in the input image may +be used to select the data to be used and for which an iillumination calibration +will be determined. This ability is particularly userful when dealing with +multiple slits or to exclude regions outside the slit. + +The dispersion bins may be selected by a range string (\fIbins\fR) or, +if no range string is given, by the number of bins into which the dispersion +range is to be divided (\fInbins\fR). When the interactive parameter +is set (\fIinteractive\fR) then the average spectrum is graphed and the +bins may be set using the cursor or with a colon command. Once the bins +have been selected exit with (q)uit to continue to the slit profile fitting. + +Fitting of the slit profiles is done using the interactive curve fitting +package (\fBicfit\fR). The parameters determining the fit are the +sample points, the averaging bin size, the fitting function, +the order of the function, the rejection sigmas, the number of +rejection iterations, and the rejection width. +The sample points for the average slit profile are selected by a range string. +Points in the slit profile not in the sample are not used in determining +the fitted function. The selected sample points may be binned into a +set of averages or medians which are used in the function fit instead of the +sample points with the averaging bin size parameter +\fInaverage\fR. This parameter selects the number of sample points to be +averaged if its value is positive or the number of points to be medianed +if its value is negative (naturally, the absolute value is used for the +number of points). A value of one uses all sample points without binning. +The fitted function may be used to reject points from the fit using the +parameters \fIlow_reject, high_reject, niterate\fR and \fIgrow\fR. If +one or both of the rejection limits are greater than zero then the sigma +of the residuals is computed and points with residuals less than +\fI-low_reject\fR times the sigma and greater than \fIhigh_reject\fR times +the sigma are removed and the function fitted again. In addition points +within a distance given by the parameter \fIgrow\fR of the a rejected point +are also rejected. A value of zero for this parameter rejects only the +points exceeding the rejection threshold. Finally, the rejection procedure +may be iterated the number of times given by the parameter \fIniterate\fR. + +The fitted functions may be examined and modified interactively when the +parameter \fIinteractive\fR is set. The user is asked before each dispersion +bin whether to perform the fit interactively. The possible response are +"no", "yes", "NO", and "YES". The lower case responses only affect the +specified dispersion bin while the upper case responses affect all following +dispersion bins for the current image. Thus, if the response is "NO" then +no further prompts or interactive curve fitting need be performed while if +the response is "YES" there are no further prompts but the slit profile +for each dispersion bin must be graphed and exited with (q)uit. +Changes to the fitting parameters remain in effect until they are next +changed. This allows the fitting parameters to be selected from only the first +dispersion bin without requiring each dispersion bin to be graphed and +confirmed. + +When a dispersion bin is to be fitted interactively the average slit profile +and the fitted function or the residuals of the fit are graphed. +Deleted points are marked with an x and rejected points by a diamond. +The sample regions are indicated along the bottom of the graph. +The cursor keys and colon commands are used to change the values +of the fitting parameters, delete points, and window and expand the +graph. When the fitted function is satisfactory exit with +with a carriage return or 'q'. The prompt for the next dispersion bin will +then be given until the last dispersion bin has been fit. The iillumination +calibration image is then created. +.ih +EXAMPLES +1. To create an iillumination image non-interactively: + +.nf + cl> iillumination sky illum nbins=8 order=20 interactive=no +.fi + +2. To determine independent iilluminations for a multislit image determine the +image sections defining each slit. Then the iillumination functions are +computed as follows: + +.nf + cl> iillumination sky[10:20,*],sky[35:45,*] illum,illum +.fi + +3. Generally the slit image sections are prepared in a file which is then +used to define the lists of input images and iilluminations. + +.nf + cl> iillumination @slits @illums +.fi + +3. If the DISPAXIS keyword is missing and the dispersion is running +vertically (varying with the image lines): + +.nf + cl> hedit *.imh dispaxis 2 add+ +.fi +.ih +SEE ALSO +icfit, response +.endhelp diff --git a/noao/twodspec/longslit/doc/lscombine.hlp b/noao/twodspec/longslit/doc/lscombine.hlp new file mode 100644 index 00000000..764c3b1b --- /dev/null +++ b/noao/twodspec/longslit/doc/lscombine.hlp @@ -0,0 +1,296 @@ +.help lscombine Jun04 noao.twodspec.longslit +.ih +NAME +lscombine -- Combine longslit images +.ih +USAGE +lscombine input output +.ih +PARAMETERS +.ls input +List of input two-dimensional images to combine. This task is typically +used with dispersion calibrated longslit images though it will work with +any 2D images. +.le +.ls output +Output combined image. +.le +.ls headers = "" (optional) +Optional output multiextension FITS file where each extension is a dataless +headers from each input image. +.le +.ls bpmasks = "" (optional) +Optional output bad pixel mask with good values of 0 and bad values of 1. +Output pixels are marked as bad when no input pixels contributed to the +output pixel. The file name is also added to the output image header under +the keyword BPM. +.le +.ls rejmask = "" (optional) +Optional output mask file identifying rejected or excluded pixels. The +pixel mask is the size of the output image but there is one extra dimension +with length equal to the number of input images. Each element of the +highest dimension is a mask corresponding to an input image with values of +1 for rejected or excluded pixels and values of 0 for pixels which were +used. The order of the masks is the order of the input images and image +header keywords, indexed by the pixel coordinate of the highest dimension +identify the input images. Note that the pixel positions are in the output +pixel coordinate system. +.le +.ls nrejmasks = "" (optional) +Optional output pixel mask giving the number of input pixels rejected or +excluded from the input images. +.le +.ls expmasks = "" (optional) +Optional output exposure mask giving the sum of the exposure values of +the input images with non-zero weights that contributed to that pixel. +Since masks are integer, the exposure values may be scaled to preserve +dynamic range and fractional significance. The scaling values are given in +the header under the keywords MASKSCAL and MASKZERO. Exposure values are +computed from the mask values by scale * value + zero where scale is the +value of the MASKSCAL keyword and zero is the value of the MASKZERO +keyword. +.le +.ls sigma = "" (optional) +Optional output sigma image. The sigma is the standard deviation, +corrected for a finite population, of the input pixel values (excluding +rejected pixels) about the output combined pixel values. +.le + +.ls logfile = "STDOUT" (optional) +Optional output log file. If no file is specified then no log information is +produced. The special filename "STDOUT" prints log information to the +terminal. +.le + +.ls interptype = "spline3" +Image interpolation type for any resampling prior to combining. +The allowed types are "nearest" (nearest neighbor), "linear" (bilinear), +"poly3" (bicubic polynomial), "poly5" (biquintic polynomial), and "spline3" +(bicubic polynomial). +.le +.ls x1 = INDEF, y1 = INDEF +User coordinates of the first output column and line. If INDEF then it +is based on the smallest value over all the images. +.le +.ls x2 = INDEF, y2 = INDEF +User coordinates of the last output column and line. If INDEF then it +is based on the largest value over all the images. +.le +.ls dx = INDEF, dy = INDEF +User coordinate pixel interval of the output. If INDEF then the it +is based on smallest interval (i.e. highest dispersion) over all the images. +.le +.ls nx = INDEF, ny = INDEF +Number of output pixels. If INDEF then it is based on the values of the +other coordinate parameters. +.le + +.ls combine = "average" (average|median|sum) +Type of combining operation performed on the final set of pixels (after +offsetting, masking, thresholding, and rejection). The choices are +"average", "median", or "sum". The median uses the average of the two central +values when the number of pixels is even. For the average and sum, the +pixel values are multiplied by the weights (1 if no weighting is used) +and summed. The average is computed by dividing by the sum of the weights. +If the sum of the weights is zero then the unweighted average is used. +.le +.ls reject = "none" (none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip) +Type of rejection operation performed on the pixels remaining after offsetting, +masking and thresholding. The algorithms are described in the +DESCRIPTION section. The rejection choices are: + +.nf + none - No rejection + minmax - Reject the nlow and nhigh pixels + ccdclip - Reject pixels using CCD noise parameters + crreject - Reject only positive pixels using CCD noise parameters + sigclip - Reject pixels using a sigma clipping algorithm + avsigclip - Reject pixels using an averaged sigma clipping algorithm + pclip - Reject pixels using sigma based on percentiles +.fi + +.le +.ls outtype = "real" (none|short|ushort|integer|long|real|double) +Output image pixel datatype. The pixel datatypes are "double", "real", +"long", "integer", unsigned short "ushort", and "short" with highest +precedence first. If "none" is specified then the highest precedence +datatype of the input images is used. When there is a mixture of +short and unsigned short images the highest precedence become integer. +The datatypes may be abbreviated to a single character. +.le +.ls outlimits = "" +Output region limits in pixels specified as pairs of whitespace separated +values. The first two numbers are the limits along the first output image +dimension, the next two numbers are the limits along the second dimension, +and so on. If the higher dimension limits are not specified they default +to the full range. Therefore, if no limits are specified then the full +output is created. Note that the output size is computed from all the +input images including offsets if specified and the coordinates are +relative to that size. +.le +.ls masktype = "none" (none|goodvalue) +Type of pixel masking to use. If "none" then no pixel masking is done +even if an image has an associated pixel mask. Otherwise the +value "goodvalue" will use any mask specified for the image under +the BPM keyword. The values of the mask will be interpreted as +zero for good pixels and non-zero for bad pixels. The mask pixels +are assumed to be registered with the image pixels. +.le +.ls blank = 0. +Output value to be used when there are no pixels. +.le + +.ls scale = "none" (none|mode|median|mean|exposure|@<file>|!<keyword>) +Multiplicative image scaling to be applied. The choices are none, multiply +by the reciprocal of the mode, median, or mean of the specified statistics +section, multiply by the reciprocal of the exposure time in the image header, +multiply by the values in a specified file, or multiply by a specified +image header keyword. When specified in a file the scales must be one per +line in the order of the input images. +.le +.ls zero = "none" (none|mode|median|mean|@<file>|!<keyword>) +Additive zero level image shifts to be applied. The choices are none, add +the negative of the mode, median, or mean of the specified statistics +section, add the values given in a file, or add the values given by an +image header keyword. When specified in a file the zero values must be one +per line in the order of the input images. File or keyword zero offset +values do not allow a correction to the weights. +.le +.ls weight = "none" (none|mode|median|mean|exposure|@<file>|!<keyword>) +Weights to be applied during the final averaging. The choices are none, +the mode, median, or mean of the specified statistics section, the exposure +time, values given in a file, or values given by an image header keyword. +When specified in a file the weights must be one per line in the order of +the input images and the only adjustment made by the task is for the number of +images previously combined. In this case the weights should be those +appropriate for the scaled images which would normally be the inverse +of the variance in the scaled image. +.le +.ls statsec = "" +Section of images to use in computing image statistics for scaling and +weighting. If no section is given then the entire region of the input is +sampled (for efficiency the images are sampled if they are big enough). +When the images are offset relative to each other one can precede the image +section with one of the modifiers "input", "output", "overlap". The first +interprets the section relative to the input image (which is equivalent to +not specifying a modifier), the second interprets the section relative to +the output image, and the last selects the common overlap and any following +section is ignored. +.le +.ls expname = "" +Image header keyword to be used with the exposure scaling and weighting +options. Also if an exposure keyword is specified that keyword will be +added to the output image using a weighted average of the input exposure +values. +.le + +.ce +Algorithm Parameters +.ls lthreshold = INDEF, hthreshold = INDEF +Low and high thresholds to be applied to the input pixels. This is done +before any scaling, rejection, and combining. If INDEF the thresholds +are not used. +.le +.ls nlow = 1, nhigh = 1 (minmax) +The number of low and high pixels to be rejected by the "minmax" algorithm. +These numbers are converted to fractions of the total number of input images +so that if no rejections have taken place the specified number of pixels +are rejected while if pixels have been rejected by masking, thresholding, +or nonoverlap, then the fraction of the remaining pixels, truncated +to an integer, is used. +.le +.ls nkeep = 1 +The minimum number of pixels to retain or the maximum number to reject +when using the clipping algorithms (ccdclip, crreject, sigclip, +avsigclip, or pclip). When given as a positive value this is the minimum +number to keep. When given as a negative value the absolute value is +the maximum number to reject. The latter is in addition to pixels +missing due to non-overlapping offsets, bad pixel masks, or thresholds. +.le +.ls mclip = yes (ccdclip, crreject, sigclip, avsigcliip) +Use the median as the estimate for the true intensity rather than the +average with high and low values excluded in the "ccdclip", "crreject", +"sigclip", and "avsigclip" algorithms? The median is a better estimator +in the presence of data which one wants to reject than the average. +However, computing the median is slower than the average. +.le +.ls lsigma = 3., hsigma = 3. (ccdclip, crreject, sigclip, avsigclip, pclip) +Low and high sigma clipping factors for the "ccdclip", "crreject", "sigclip", +"avsigclip", and "pclip" algorithms. They multiply a "sigma" factor +produced by the algorithm to select a point below and above the average or +median value for rejecting pixels. The lower sigma is ignored for the +"crreject" algorithm. +.le +.ls rdnoise = "0.", gain = "1.", snoise = "0." (ccdclip, crreject) +CCD readout noise in electrons, gain in electrons/DN, and sensitivity noise +as a fraction. These parameters are used with the "ccdclip" and "crreject" +algorithms. The values may be either numeric or an image header keyword +which contains the value. The noise model for a pixel is: + +.nf + variance in DN = (rdnoise/gain)^2 + DN/gain + (snoise*DN)^2 + variance in e- = (rdnoise)^2 + (gain*DN) + (snoise*(gain*DN))^2 + = rdnoise^2 + Ne + (snoise * Ne)^2 +.fi + +where DN is the data number and Ne is the number of electrons. Sensitivity +noise typically comes from noise introduced during flat fielding. +.le +.ls sigscale = 0.1 (ccdclip, crreject, sigclip, avsigclip) +This parameter determines when poisson corrections are made to the +computation of a sigma for images with different scale factors. If all +relative scales are within this value of unity and all relative zero level +offsets are within this fraction of the mean then no correction is made. +The idea is that if the images are all similarly though not identically +scaled, the extra computations involved in making poisson corrections for +variations in the sigmas can be skipped. A value of zero will apply the +corrections except in the case of equal images and a large value can be +used if the sigmas of pixels in the images are independent of scale and +zero level. +.le +.ls pclip = -0.5 (pclip) +Percentile clipping algorithm parameter. If greater than +one in absolute value then it specifies a number of pixels above or +below the median to use for computing the clipping sigma. If less +than one in absolute value then it specifies the fraction of the pixels +above or below the median to use. A positive value selects a point +above the median and a negative value selects a point below the median. +The default of -0.5 selects approximately the quartile point. +.le +.ls grow = 0. +Radius in pixels for additional pixel to be rejected in an image with a +rejected pixel from one of the rejection algorithms. This applies only to +pixels rejected by one of the rejection algorithms and not the masked or +threshold rejected pixels. +.le +.ih +DESCRIPTION +\fBLSCOMBINE\fR combines two-dimensional longslit images by first +resampling them to a common world coordinate system, if not already on +the same system, and then combining the matching pixels. The final world +coordinate system is specified by parameters or by looking at the maximum +ranges and minimum intervals over the input data. + +Algorithmically it is a combination of the tasks \fBTRANSFORM\fR (using +the WCS) and \fBIMCOMBINE\fR. When executing it will generate temporary +images ("lsc*") and masks ("mlsc*") if the images are not already on a +common world coordinate system. The user only need be aware of this +in case of an unexpected abort leaving these files behind. + +Rather than repeat the details the user should consult the descriptions +for \fBTRANSFORM\fR and \fBIMCOMBINE\fR ignoring parameters which are +not part of this task. +.ih +EXAMPLES +.nf + cl> lscombine obj* lscomb +.fi +.ih +NOTES +.ls LSCOMBINE: V2.12.3 +This is a new task in this relese. +.le +.ih +SEE ALSO +transform, imcombine. odcombine +.endhelp diff --git a/noao/twodspec/longslit/doc/lslit.ms b/noao/twodspec/longslit/doc/lslit.ms new file mode 100644 index 00000000..de35424f --- /dev/null +++ b/noao/twodspec/longslit/doc/lslit.ms @@ -0,0 +1,712 @@ +.nr PS 9 +.nr VS 10 +.ps 9 +.vs 10 +.po 0.50i +.nr PO 0.50i +.ll 7.0i +.nr LL 7.0i +.nr PD 1v +.EQ +delim $$ +.EN +.TL +Reduction of long slit spectra with IRAF +.AU +Francisco Valdes +.AI +IRAF Group, Central Computer Services, National Optical Astronomy Observatories +P.O. Box 26732, Tucson, Arizona, 85726 +March 1986 +.AB +Tools for the reduction of long slit spectra within the Interactive +Data Reduction and Analysis Facility (IRAF) at the National Optical +Astronomy Observatory (NOAO) are described. The user interface +(commands and special features) and the algorithms are discussed. +Application of the reduction package to multi-slit images is briefly +outlined. The author developed and supports the package at NOAO. +.AE +.LP + +.ce +\fB1. Introduction\fR +.PP +This paper describes the tools currently available within the Interactive Data +Reduction and Analysis Facility (IRAF) at the National Optical +Astronomy Observatories (NOAO) for the reduction of long slit spectra. +The reduction tools, called tasks, are organized as an IRAF package +called \fBlongslit\fR. The tasks in the package are summarized below. + +.TS +center; +n n. +apdefine \&- Define apertures for 1D aperture extraction identify \&- Identify features +apextract \&- Extract 1D aperture spectra illumination \&- Determine illumination calibration +background \&- Fit and subtract a line or column background reidentify \&- Reidentify features +extinction \&- Apply atmospheric extinction corrections to images response \&- Determine response calibration +fitcoords \&- Fit user coordinates to image coordinates setimhdr \&- Set longslit image header parameters +fluxcalib \&- Apply flux calibration to images transform \&- Transform longslit images to user coordinates +.TE + +.PP +Since there are many types of long slit spectra, detectors, and +astronomical goals we do not describe a reduction procedure or path. +Reduction manuals giving cookbook instructions for the reduction of +certain types of data at NOAO are available from the Central Computer +Services Division. Instead, each task is discussed separately. The +primary emphasis is on the algorithms. +.PP +The following terminology is used in this paper. A \fIlong slit +spectrum\fR is a two dimensional image. The two image axes are +called \fIaxis 1\fR and \fIaxis 2\fR and the pixel coordinates are +given in terms of \fIcolumns\fR and \fIlines\fR. The long slit +axes are called the \fIdispersion axis\fR and the \fIslit +axis\fR. The reduction tasks do not require a particular orientation +of the dispersion and slit axes, however, these axes should be +fairly closely aligned with the image axes. \fBIn the remainder of +this paper the slit axis will correspond to image axis 1 and +the dispersion axis with image axis 2\fR. +.PP +There are five types of operations performed by the tasks in the +\fBlongslit\fR package: (1) detector response calibration, (2) geometric +distortion and coordinate rectification, (3) background sky subtraction, +(4) flux calibration, and (5) aperture extraction of one dimensional spectra. +These are listed in the order in which they are usually performed and in +which they are discussed in this paper. There is also an initialization +task, \fBsetimhdr\fR, and a general routine, \fBicfit\fR, used in may of the +long slit tasks. These are described first. +.SH +SETIMHDR - Set long slit image header parameters +.PP +The tasks in the \fBlongslit\fR package use information contained in the IRAF +image header. The task \fBsetimhdr\fR sets a required parameter in the image +header advising the long slit tasks which image axis corresponds to the +dispersion axis; the tasks work equally well with the dispersion axis +aligned with the image lines or the image columns. This is generally +the first task executed when reducing long slit spectra. +.SH +ICFIT - The IRAF Interactive Curve Fitting routine +.PP +Many of the tasks in the IRAF which fit a one dimensional function +utilize the same powerful interactive curve fitting routine called +\fBicfit\fR. This routine allows the user to perform sophisticated +function fitting interactively and graphically or to specify the +function fitting parameters in advance and run the task +non-interactively. That this routine is used in many tasks also has +the advantage that the user need not learn a new set of commands and +features for each task requiring function fitting. +.PP +The features of the this curve fitting tool include: +.IP (1) +A choice of four fitting functions; Chebyshev polynomial, Legendre polynomial, +a linear spline, and a cubic spline. +.nr PD 0v +.IP (2) +A choice of the polynomial order or the number of spline pieces. +.IP (3) +Deletion of individual points from the fit. +.IP (4) +Selection of a sample or subset of points to be fit (excluding the rest). +.IP (5) +Iterative deletion of points with large residuals from the fitted function. +.IP (6) +Binning sets of neighboring points into averages or medians which are then +fit instead of the individual points. +.nr PD 1v +.LP +In addition to the above features the interactive graphics mode allows +the user to: +.IP (1) +Iterate any number of times on the fitting parameters. +.nr PD 0v +.IP (2) +Display the fit in several different ways; residuals, ratios, and the fit +overplotted on the data points. +.IP (3) +Manipulate the graphs using a large set of commands for formating and +expanding any part of a graph for detailed examination. +.IP (4) +Produce copies of the graphs with a snap-shot command. +.nr PD 1v +.PP +For the applications described in this paper the most important features +are the ability to adjust the function order, exclude bad points, and +select subsets of points to be fit. Other useful features are taking the +median or average of a set of points before fitting and iteratively +rejecting deviant points. When used non-interactively the user +selects the function and the order. The \fBlongslit\fR tasks using the +interactive curve fitting routine are \fBbackground\fR, \fBidentify\fR, +\fBillumination\fR, and \fBresponse\fR. + + +.ce +\fB2. Detector Response Calibrations\fR +.PP +The relative response of the pixels in the detector and the transmission +of the spectrograph along the slit are generally not uniform. Outside +of the \fBlongslit\fR package are IRAF tasks for creating \fIflat fields\fR +from quartz lamp calibration images which correct for small scale response +variations. Flat fields, however, do not correct for spectrograph +transmission variations or any large scale response patterns. The tasks +\fBresponse\fR and \fBillumination\fR are specially designed for long slit +spectra to correct both the small scale variations as well as +larger scale response patterns and slit illumination and transmission effects. +.PP +These algorithms make the assumption that the wavelength and slit axis +are very nearly aligned with the image lines and columns. If this is +not true then the images must be aligned first or alternate response +calibration methods used. +.SH +RESPONSE - Determine response calibration +.PP +The task \fBresponse\fR is used with calibration images which (1) +do not have any intrinsic structure along the slit dimension and (2) +have a smooth spectrum without emission or absorption features. +Typically the calibration images consist of quartz lamp exposures. +The idea is to determine a response correction that turns an observed +calibration image into one which is identical at all points along the +slit. +.PP +From (1) a one dimensional spectrum is obtained by averaging along the +slit; i.e. averaging the columns. Based on (2) a smoothing function is +fit to the one dimensional spectrum to reduce noise and eliminate +response effects which are coherent in wavelength such as fringing. +The response correction for each pixel is then obtained by dividing +each point along the slit (the columns) by the smoothed one dimensional +spectrum. +.PP +The purpose of fitting a function to the one dimensional spectrum is to +reduce noise and to remove coherent response effects which are not part +of the true quartz spectrum. Examples of coherent response effects are +fringing and regions of low or high response running along the slit +dimension which are, therefore, not averaged out in the one dimensional +spectrum. The choice of smoothing function is dictated by the behavior +of the particular detector. Difficult cases are treated with the +interactive graphical function fitting routine \fBicfit\fR. For the +automated case the user specifies the smoothing function and order. +.PP +This calibration algorithm has the advantage of removing spatial +frequencies at almost all scales; in particular, there is no modeling +of the response pattern along the slit dimension. The only modeling is +the fit to the \fBaverage\fR spectrum of the calibration source. In +tests at NOAO this algorithm was able to reduce the response variations +to less 0.2%, to correct for a broad diagonal region of low response in +one of the CCD detectors (the CRYOCAM), and to remove strong fringing +in spectra taken in the red portion of the spectrum where the detector +is particularly subject to fringing. +.PP +One feature common to \fBresponse\fR and \fBillumination\fR is that +the algorithm can be restricted to a section of the calibration image. +The response corrections are then determined only within that section. +If a response image does not exist initially then the response values outside +the section are set to unity. If the response image does exist then +the points outside the section are not changed. This feature is used +with data containing several slits on one image such as produced by +the multi-slit masks at Kitt Peak National Observatory. +.PP +When there are many calibration images this algorithm may be applied to +each image separately or to an average of the images. If applied +separately the response images may be averaged or applied to the +appropriate long slit spectra; typically the one nearest the object +exposure in time or telescope position. The task allows a list of +calibration images from which a set of response corrections is +determined. +.PP +Figure 1 shows a portion of an average quartz spectrum ratioed with the +smooth fit to the spectrum. It is one of the graphs which can be +produced with the \fBicfit\fR routine and, with the other figures in +this paper, illustrates the formating, +zooming, and snap-shot capabilities in IRAF. The figure shows considerable +structure of periodic high response lines and fringing which, because +they are primarily aligned with the image lines, are still present in +the average quartz spectrum. Note that this is not the response +since it is the average of all the columns; an actual response column +would have much larger variations including pixel-to-pixel response +differences as well as large scale response patterns such as the diagonal +structure mentioned previously. +.SH +ILLUMINATION - Determine illumination calibration +.PP +The task \fBillumination\fR corrects for large scale variations along +the slit and dispersion dimensions due to illumination or spectrograph +transmission variations (often called the \fIslit profile\fR). When +the detector response function is determined from quartz calibration +images, using \fBresponse\fR, an illumination error may be introduced +due to differences in the way the spectrograph is illuminated by the +quartz lamp compared to that of an astronomical exposure. This +violates the the assumption that the calibration spectrum has no +intrinsic structure along the slit. \fBIllumination\fR is also used +when only the small scale response variations have been removed using a +flat field correction. +.PP +The approach to determining the response correction is similar to that +described for \fBresponse\fR. Namely, the response correction is the +ratio of a calibration image to the expected calibration image. Again, +the expected calibration image is that which has no structure along the +slit. Calibration images may be quartz lamp exposures, assuming there +is no illumination problem, and blank sky exposures. In the worst +case, object exposures also may be used if the extent of the object in +the slit is small. +.PP +There are several important differences between this algorithm and that +of \fBresponse\fR: +.IP (1) +The spectra are not required to be smooth in wavelength and may contain +strong emission and absorption lines. +.nr PD 0v +.IP (2) +The response correction is a smooth, large scale function only. +.IP (3) +Since the signal-to-noise of spectra from blank sky and object images is +lower than quartz calibration images, steps must be taken to minimize noise. +.IP (4) +Care must be taken that the spectral features do not affect the +response determination. +.nr PD 1v +.PP +The algorithm which satisfies these requirements is as follows. First the +calibration spectrum is binned in wavelength. This addresses the +signal-to-noise consideration (3) and is permitted because only large +scale response variations are being determined (2). Next a smoothing +function is fit along the slit dimension in each bin; i.e. each +wavelength bin is smoothed to reduce noise and determine the large +scale slit profile. Then each bin is normalized to the central point +in the slit to remove the spectral signature of the calibration image. +Finally, the binned response is interpolated back to the +original image size. +.PP +The normalization to the central point in the slit is an assumption +which limits the ability of the illumination algorithm to correct +for all wavelength dependent response effects. There is a wavelength +dependence, however, in that the slit profile is a function of the +wavelength though normalized to unity at the central point of the +slit. +.PP +The wavelength bins and bin widths need not be constant. The bins are +chosen to sample the large scale variations in the slit profile as a +function of wavelength, to obtain good signal statistics, and to avoid +effects due to variations in the positions and widths of strong +emission lines. This last point means that bin boundaries should not +intersect strong emission lines though the bin itself may and should +contain strong lines. Another way to put this criterion is that +changes in the data in the wavelength bins should be small when the +bin boundaries are changed slightly. +.PP +The bins may be set interactively using a graph of the average +spectrum or automatically by dividing the dispersion axis into a +specified number of equal width bins. When the number of bins is small +(and the number of wavelength points in each bin is large) bin +boundary effects are likely to be insignificant. +A single bin consisting of all wavelengths, i.e. the sum of all the image +lines, may be used if no wavelength dependence is expected in the +response. Illumination effects introduced with \fBresponse\fR, +however, appear as wavelength dependent variations in the slit +profile. +.PP +Smoothing of each bin along the slit dimension is done with the +interactive curve fitting routine. The curve fitting may be done +graphically and interactively on any set of bins or automatically by +specifying the function and order initially. The fitting should be +done interactively (at least on the first bin) in order to exclude +objects when the sky is not truly blank and contains faint objects or +when object exposures must be used to determine the slit profile. +.PP +As with \fBresponse\fR, several blank sky images may be available +(though this is less often true in practice). An illumination +correction may be determined for each calibration image or one +illumination correction may be computed from the average of the +calibration images. Also the illumination response correction may be +determined for only a section of the calibration image so as to be +applicable to multi-slit data. +.PP +Figure 2 shows the fit to one of the wavelength bins; lines 1 to 150 have been +summed and the sum is plotted as a function of slit position (column). +The data is from a response image produced by \fBresponse\fR. This +figure illustrates a number of things. \fBIllumination\fR may be run +on a response image to remove the large scale illumination and slit +transmission effects. This creates a flat field in a manner different than +normal surface fitting. The figure shows that response effects occur +at all scales (keeping in mind that the pixel-to-pixel response has +been largely averaged out by summing 150 columns). It also illustrates +how the illumination algorithm works for a typical slit profile. In +this example about half the large scale variation in the slit profile +is due to illumination effects and half is real slit transmission +variations. For a blank sky or object image the main differences +would be larger data values (hundreds to thousands) and possibly +objects present in the slit to be excluded from the fit. + + +.ce +\fB3. Distortion Corrections and Coordinate Transformations\fR +.PP +The removal of geometric distortions and the application of coordinate +transformations are closely related. Both involve applying a +transformation to the observed image to form the desired final image. +Generally, both steps are combined into a single image transformation +producing distortion corrected images with linear wavelength +coordinates (though the pixel interval may be logarithmic). +This differs from other systems (for example, the Kitt Peak IPPS) which +perform distortion corrections on each axis independently and then +apply a dispersion correction on the distortion corrected image. +While this approach is modular it requires several transformations of +the images and does not couple the distortions in each dimension into +a single two dimensional distortion. +.PP +To transform long slit images requires (1) identifying spectral +features and measuring their positions in arc lamp or sky +exposures at a number of points in the image, (2) determining the +distortions in the slit positions at a number of points along the +dispersion axis using either calibration images taken with special +masks or narrow objects such as stars, +(3) determining a transformation function between the image +coordinates and the user coordinates for the measured wavelength and +slit positions, (4) and interpolating the images to a uniform grid in +the user coordinates according to the transformation function. The +coordinate feature information and the transformation functions are +stored in a database. If needed, the database may be examined and +edited. +.PP +An important part of this task is the feature center determination. This +algorithm is described in a separate section below. +.SH +IDENTIFY - Identify features +.PP +The tasks \fBidentify\fR and \fBreidentify\fR are general tools used +for one dimensional, multi-aperture, multi-slit, echelle, and long slit +spectra. The tasks are also general in the sense that they are used to +identify features in any one dimensional vector. For long slit +reductions they are used to identify and trace objects in the slit and +to identify, trace, and determine wavelength solutions for spectral +features from arc calibration images and from sky and object +exposures. +.PP +\fBIdentify\fR is used to identify emission or absorption features in a +one dimensional projection of an image. This projection consists of an +image line or column or the +average of many lines or columns. Averaging is used to increase the +signal in weak features and provide better accuracy in determining the +one dimensional positions of the features. The identified features are +assigned user coordinates. The user coordinates will ultimately define +the final coordinates of the rectified images. +.PP +For determining the distortions along the slit, the positions of object +profiles or profiles obtained with multi-aperture masks in the slit +are measured at a reference line. The user coordinates are then taken to be +the positions at this reference line. The +coordinate rectification will then correct for the distortion to bring the +object positions at the other lines to the same position. +(Note that it is feasible to make an actual coordinate transformation of +the spatial axis to arc seconds or some other units). +.PP +For wavelength features arc calibration images are generally used, +though sky and object exposures can also be used if necessary. After +marking a number of spectral features and assigning them wavelength +coordinates a \fIdispersion solution\fR can be computed relating the +image coordinate to the wavelength; $lambda~=~f(l)$, where $lambda$ is +wavelength and $l$ is the image line. The dispersion +solution is determined using the \fBicfit\fR routines described +earlier. This dispersion solution is used in the long slit package +only as an aid in finding misidentified lines and to automatically add +new features from a wavelength list. The dispersion solution actually +used in transforming the images is a two dimensional function +determined with the task \fBfitcoords\fR. +.PP +Figure 3 shows a graph from \fBidentify\fR used on a Helium-Neon-Argon +arc calibration image. Only three lines were identified interactively +and the reminder were added automatically from a standard line list. +Note that the abscissa is in wavelength units and the ordinate is +displayed logarithmically. The latter again illustrates the flexibility +the user has to modify the graph formats. Each marked feature is +stored in a database and is automatically reidentified at other columns +in the image with \fBreidentify\fR. +.SH +REIDENTIFY - Reidentify features +.PP +The task \fBreidentify\fR automatically reidentifies the spectral and +object features and measures their positions at a number of other +columns and lines starting from those identified interactively with +\fBidentify\fR. The algorithms and the feature information produced is +the same as that of \fBidentify\fR including averaging a number of +lines or columns to enhance weak features. The automatic tracing can +be set to stop or continue when a feature fails to be found in a new +column or line; failure is defined by the position either becoming +indeterminate or shifting by more than a specified amount +(\fIcradius\fR defined in the next section). +.SH +CENTER1D - One dimensional feature centering +.PP +The one dimensional position of a feature is determined by solving the equation + +.EQ +define I0 'I sub 0' +define XC 'X sub c' +.EN +.EQ (1) +int ( I - I0 ) f( X - XC ) dX~=~0 +.EN + +where $I$ is the intensity at position $X$, $I0$ is the continuum +intensity, $X$ is the vector coordinate, and $XC$ is the desired +feature position. The convolution function $f(X- XC )$ is a +sawtooth as shown in figure 4. For absorption features the negative of this +function is used. The figure defines the parameter \fIfwidth\fR which +is set to be approximately the width of the feature. If it is too +large the centering may be affected by neighboring features and if it +is too small the accuracy is worse. +.PP +For emission features the continuum, $I0$, is assumed to be zero. +For absorption features the continuum +is the maximum value in the region around the initial guess +for $XC$. The size of the region on each side of the initial guess is +the sum of \fIfwidth\fR/2, to allow for the feature itself, \fIcradius\fR, +to allow for the uncertainty in the feature position, and \fIfwidth\fR, for a +buffer. Admittedly this is +not the best continuum but it contains the fewest assumptions and is +tolerant of nearby contaminating features. +.PP +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 the user defined +distance \fIcradius\fR from the initial guess or outside of the data +vector then the position is considered to be indefinite. +.SH +FITCOORDS - Fit user coordinates to image coordinates +.PP +Let us denote the image coordinates of a point in the two dimensional +image as $(c,~l)$ where $c$ is the column coordinate +and $l$ is the line coordinate. Similarly, denote the +long slit coordinates as $(s,~lambda )$ where $s$ is +the slit position and $lambda$ is the wavelength. +The results of \fBidentify\fR and \fBreidentify\fR is a set of points +$(c,~l,~s)$ and $(c,~l,~lambda )$ recorded in the database. +.PP +Two dimensional functions of the image coordinates are fit to the user +coordinates for each set of slit and wavelength features, +$s~=~t sub s (c, l)$ and $lambda~=~t sub lambda (c, l)$, which are +stored in the database. +Note that the second function is a two dimensional dispersion solution. +It is this function which is used to transform the long slit images to +linear wavelength coordinates. Many images may be used to create a +single transformation or each calibration images may be used separately +to create a set of transformations. +.PP +This task has both an interactive and non-interactive mode. For the +non-interactive mode the user specifies the transformation function, +either a two dimensional Chebyshev or Legendre polynomial, and separate +orders for the column and line axes. When run interactively the +user can try different functions and orders, delete bad points, and +examine the data and the transformation in a variety of graphical formats. +The interactive option is quite useful in initially setting the +transformation function parameters and deleting bad points. +The two dimensional function fitting routine is similar in spirit to the +\fBicfit\fR one dimensional function fitting routine. It is possible +that this routine may find uses in other IRAF tasks. +.PP +Figure 5 shows a graph from \fBfitcoords\fR. The feature image coordinates +of four objects in the slit (the first of which is very weak) +from \fBidentify\fR and \fBreidentify\fR are plotted. This information +is used to measure the distortion of the spectrograph in the slit axis. +This example shows particularly gross distortions; often the distortions +would not be visible in such a graph, though expanding it would make +the distortion visible. The transformation surface fit to this data +removes this distortion almost entirely as seen in the residual plot +of figure 6. Figure 7 shows the equivalent residual plot for the +wavelength coordinates; a two dimensional dispersion solution. +.SH +TRANSFORM - Transform long slit images to user coordinates +.PP +The coordinate transformations determined with the task \fBfitcoords\fR are +read from the database. The transformations are evaluated on a grid of +columns and lines, $s sub i~=~t sub s (c sub i , l sub i )$ and +$lambda sub i~=~t sub lambda (c sub i , l sub i )$. +If no transformation is defined for a particular dimension then a unit +transformation is used. If more than one transformation for a dimension +is given then a set of points is computed for each transformation. +The inverse transformations are obtained by fitting transformation +functions of the same type and orders to the set of slit position and +wavelength points. Note how this allows combining separate +transformations into one inverse transformation. +.PP +The inverse transformations, $c~=~t sub c (s, lambda )$ and +$l~=~t sub l (s, lambda )$, are used to rectify a set of input images. +The user specifies a linear grid for the transformed images by defining some +subset of the starting and ending coordinates, the pixel interval, and the +number of points. In addition the pixel interval can be specified to be +logarithmic; used primarily on the wavelength axis for radial +velocity studies. The inverse transformations define the image column +and line to be interpolated in the input image. The user has the choice +of several types of image interpolation; bilinear, bicubic, and biquintic +polynomials and bicubic spline. In addition the interpolation +can be specified to conserve flux by multiplying the interpolated value +by the Jacobian of the transformation. +.PP +The wavelength of the first pixel and the pixel wavelength interval are +recorded in image headers for later use in making plots and in the +\fBonedspec\fR package. In addition a flag is set in the header indicating +that the image has been dispersion corrected. + + +.ce +\fB4. Background Subtraction\fR +.SH +BACKGROUND - Fit and subtract a line or column background +.PP +If required, the background sky at each wavelength is subtracted from +the objects using regions of the slit not occupied by the object. +This must be done on coordinate rectified images since the lines or +columns of the image must correspond exactly to the same wavelength. +A set of points along the slit dimension, which are representative of the +background, are chosen interactively. Generally this will consist of two +strips on either side of the object spectrum. +At each wavelength a low order function is fit to the sky points and then +subtracted from the entire line or column. +.PP +Ideally the response corrections and coordinate rectification will make +the background sky constant at all points on the slit at each +wavelength and the subtracted background is just a constant. However, if +desired a higher order function may be used to correct for +deficiencies in the data. A possible problem is focus variations which +cause the width of the sky emission lines to vary along the slit. One +may partially compensate for the focus variations by using a higher +order background fitting function. +.PP +The background fitting uses the +interactive curve fitting routine \fBicfit\fR described earlier. +Figure 8 shows a graph from \fBbackground\fR illustrating how the user +sets two sample regions defining the sky (indicated a the bottom of +the graph). + + +.ce +\fB5. Flux Calibration\fR +.SH +EXTINCTION - Apply atmospheric extinction corrections to images +.PP +A set of coordinate rectified images is corrected for atmospheric +extinction with the task \fBextinction\fR. The extinction correction +is given by the formula + +.EQ + roman {correction~factor}~=~10 sup {0.4~E sub lambda~A} +.EN + +where $E sub lambda$ are tabulated extinctions values and $A$ is the air +mass of the observation (determined from information in the image +header). The tabulated extinctions are interpolated to the wavelength of +each pixel and the correction applied to the input pixel value to form +the output pixel value. The user may supply the extinction table but +generally a standard extinction table is used. +.PP +The air mass is sought in the image header under the keyword AIRMASS. +If the air mass is not found then it is computed from the zenith +distance, ZD, using the approximation formula from Allen's +"Astrophysical Quantities", 1973, pages 125 and 133 + +.EQ + A = ( cos ( roman ZD ) sup 2~+~2 s~+~1) sup half +.EN + +where $s$, the atmospheric scale height, is set to be 750. If the +zenith distance is not found then it must be computed from the +hour angle, the declination, and the observation latitude. The +hour angle may be computed from the right ascension and the siderial time. +Computed quantities are recorded in the image header. +Flags indicating extinction correction are also set in the image +header. +.SH +FLUXCALIB - Apply flux calibration to images +.PP +The specified images are flux calibrated using a flux calibration file +derived with the \fBonedspec\fR package using standard stars. The +standard stars are extracted from response corrected, coordinate +rectified, and background subtracted long slit images using the tasks +\fBapdefine\fR and \fBapextract\fR. The standard stars must not be +extinction corrected because this is done by the \fBonedspec\fR flux +calibration algorithms. The user may specify flux per unit wavelength, +$roman F sub lambda$, or flux per unit frequency, $roman F sub nu$. +The flux is computed using the exposure time and dispersion from the +image headers and a flux calibration flag is set. + + +.ce +\fB6. Extraction of One Dimensional Spectra\fR +.PP +The user may wish to extract one dimensional spectra at various points +along the slit. As mentioned earlier, this is necessary if observations +of standard stars are to be used to calibrate the fluxes. The flux +calibration values are determined from one dimensional spectra of standard +stars using the \fBonedspec\fR package. The tools to extract +one dimensional aperture spectra from long slit spectra are \fBapdefine\fR and +\fBapextract\fR. +.SH +APDEFINE - Define apertures for 1D aperture extraction +.PP +Extraction apertures are defined as a list consisting of an +aperture number and lower and upper limits for the aperture. The aperture +limits are specified as column or line positions which need not be +integers. The user may create a file containing these +aperture definitions with an editor or use the interactive +graphics task \fBapdefine\fR. +.PP +\fBApdefine\fR graphs the sum of a number of lines or columns (depending +on the dispersion axis) and allows the user to interactively define and +adjust apertures either with the cursor or using explicit commands. +If an aperture definition file exists the apertures are indicated on +the graph initially. When the user is done a new aperture definition +file is written. +.SH +APEXTRACT - Extract 1D aperture spectra +.PP +One dimensional aperture spectra are extracted from a list of +long slit images using an aperture definition file. The extraction +consists of the sum of the pixels, including partial pixels, at +each column or line along the dispersion axis between the aperture limits. +.PP +More sophisticated algorithms than simple strip extraction are available +in IRAF and will soon be incorporated in the long slit package. The +other extraction tasks trace the positions of features, i.e. the aperture +is not fixed at certain columns or lines, and allow weighted extractions +and detecting and removing bad pixels such as cosmic rays. The +weighted extractions can be chosen to be optimal in a statistical sense. + + +.ce +\fBConclusion\fR +.PP +The IRAF long slit reduction tasks have been used at NOAO for about six +months and have yielded good results. The package does not contain specific +analysis tasks. Some analysis task will be added in time. The package +is part of the software distributed with release of the IRAF. The +author of this paper wrote and supports the tasks described here. +Any comments are welcome. +.sp5 +.ll 4.2i +.nr LL 4.2i +.LP +\fBCaptions for Figures:\fP +.sp 1 +Figure 1. Ratio of average quartz spectrum to fit of a 20 piece cubic spline +for determination of response correction using \fBresponse\fR. + +Figure 2. Fit of 4 piece cubic spline to the slit profile from the average +of the first 150 lines in a response image using \fBillumination\fR. + +Figure 3. Identification of emission lines from the central column of a +Helium-Neon-Argon spectrum using task \fBidentify\fR. + +Figure 4. Sawtooth convolution function of width \fIfwidth\fR used in the +profile centering algorithm. + +Figure 5. Graph of stellar object positions identified with \fBidentify\fR, +traced with \fBreidentify\fR, and graphed by \fBfitcoords\fR showing the +spectrograph distortions. + +Figure 6. Residuals of the fit of a two dimensional 6th order Chebyshev +polynomial to the data of figure 5 using \fBfitcoords\fR. + +Figure 7. Residuals of the fit of a two dimensional 6th order Chebyshev +polynomial to the image positions of wavelength features using \fBfitcoords\fR. + +Figure 8. Constant background fit to a line of an object spectrum using +\fBbackground\fR. The marks at the bottom of the graph indicate the +set of points used in the fit. diff --git a/noao/twodspec/longslit/doc/response.hlp b/noao/twodspec/longslit/doc/response.hlp new file mode 100644 index 00000000..61a7b34a --- /dev/null +++ b/noao/twodspec/longslit/doc/response.hlp @@ -0,0 +1,178 @@ +.help response Aug86 noao.twodspec.longslit +.ih +NAME +response -- Determine response calibrations +.ih +USAGE +response calibration normalization response +.ih +PARAMETERS +.ls calibration +Images to use in determining response calibrations. These are +generally quartz continuum spectra. An image section may be used to select +only a portion of the image. +.le +.ls normalization +Images to use determining the normalization spectrum. In almost all cases +the normalization images are the same as the calibration images or a +subsection of the calibration images. +.le +.ls responses +Response calibration images to be created. Each response image is paired +with a calibration image. If the image exists then it will be modified +otherwise it is created. +.le +.ls interactive = yes +Graph the average calibration spectrum and fit the normalization spectrum +interactively? +.le +.ls threshold = INDEF +Set the response to 1 when the normalization spectrum or input image data +fall below this value. If INDEF then no threshold is applied. +.le +.ls sample = "*" +Sample of points to use in fitting the average calibration spectrum. +The sample is selected with a range string. +.le +.ls naverage = 1 +Number of sample points to average or median before fitting the function. +If the number is positive the average of each set of naverage sample +points is formed while if the number is negative then the median of each set +of points (in absolute value) is formed. This subsample of points is +used in fitting the normalization spectrum. +.le +.ls function = "spline3" +Function to fit to the average image spectrum to form the normalization +spectrum. The options are "spline1", "spline3", "legendre", and "chebyshev". +.le +.ls order = 1 +Order of the fitting function or the number of spline pieces. +.le +.ls low_reject = 0., high_reject = 0. +Rejection limits below and above the fit in units of the residual sigma. +.le +.ls niterate = 1 +Number of rejection iterations. +.le +.ls grow = 0 +Reject additional points within this distance of points exceeding the +rejection threshold. +.le +.ih +CURSOR KEYS +The interactive curve fitting package \fBicfit\fR is used to fit a function +to the average calibration spectrum. Help for this package is found +under the name "icfit". +.ih +DESCRIPTION +A response calibration, in the form of an image, is created for each input +image, normally a quartz spectrum. The response calibration is formed by +dividing the calibration image by a normalization spectrum which is the +same at all points along the spatial axis. The normalization spectrum is +obtained by averaging the normalization image across the dispersion to form +a one dimensional spectrum and smoothing the spectrum by fitting a +function. The threshold value does not apply to creating or fitting of +the normalization spectrum but only the final creation of the response +values. When normalizing (that is dividing the data values by the +fit to the normalization spectrum) only pixels in which both the fitted +normalization value and the data value are above the threshold are +computed. If either the normalization value or the data value is below +the threshold the output response value is one. + +The image header keyword DISPAXIS must be present with a value of 1 for +dispersion parallel to the lines (varying with the column coordinate) or 2 +for dispersion parallel to the columns (varying with line coordinate). +This parameter may be added using \fBhedit\fR. Note that if the image has +been transposed (\fBimtranspose\fR) the dispersion axis should still refer +to the original dispersion axis unless the physical world coordinate system +is first reset (see \fBwcsreset\fR). This is done in order to allow images +which have DISPAXIS defined prior to transposing to still work correctly +without requiring this keyword to be changed. + +If the output image does not exist it is first created with unit response +everywhere. Subsequently the response is only modified in those regions +occupied by the input calibration image. Thus, image sections may be used +to select regions in which the response is desired. This ability is +particularly useful when dealing with multiple slits within an image or to +exclude regions outside the slit. + +Normally the normalization images are the same as the calibration images. +In other words the calibration image is normalized by the average spectrum +of the calibration image itself. Sometimes, however, the normalization +image may be a smaller image section of the calibration image to avoid +contaminating the normalization spectrum by effects at the edge of the +slit. Again, this may be quite useful in multi-slit images. + +The normalization spectrum is smoothed by fitting a function +using the interactive curve fitting package (\fBicfit\fR). The +parameters determining the fitted normalization spectrum are the sample +points, the averaging bin size, the fitting function, the order of the +function, the rejection sigmas, the number of rejection iterations, and +the rejection width. The sample points for the average spectrum are +selected by a range string. Points in the normalization spectrum not in the +sample are not used in determining the fitted function. The selected +sample points may be binned into a set of averages or medians which are +used in the function fit instead of the sample points with the +averaging bin size parameter \fInaverage\fR. This parameter selects +the number of sample points to be averaged if its value is positive or +the number of points to be medianed if its value is negative +(naturally, the absolute value is used for the number of points). A +value of one uses all sample points without binning. The fitted +function may be used to reject points from the fit using the parameters +\fIlow_reject, high_reject, niterate\fR and \fIgrow\fR. If one or both +of the rejection limits are greater than zero then the sigma of the +residuals is computed and points with residuals less than +\fI-low_reject\fR times the sigma and greater than \fIhigh_reject\fR +times the sigma are removed and the function fitted again. In addition +points within a distance given by the parameter \fIgrow\fR of the a +rejected point are also rejected. A value of zero for this parameter +rejects only the points exceeding the rejection threshold. Finally, +the rejection procedure may be iterated the number of times given by +the parameter \fIniterate\fR. + +The fitted function may be examined and modified interactively when the +parameter \fIinteractive\fR is set. In this case the normalization spectrum +and the fitted function or the residuals of the fit are graphed. +Deleted points are marked with an x and rejected points by a diamond. +The sample regions are indicated along the bottom of the graph. +The cursor keys and colon commands are used to change the values +of the fitting parameters, delete points, and window and expand the +graph. When the fitted function is satisfactory exit with a carriage +return or 'q' and the calibration image will be created. Changes in +the fitted parameters are remembered from image to image within the +task but not outside the task. + +When the task finishes creating a response image the fitting parameters +are updated in the parameter file. +.ih +EXAMPLES +1. To create a response image non-interactively: + + cl> response quartz quartz response order=20 interactive=no + +2. To determine independent responses for a multislit image determine the +image sections defining each slit. Then the responses are computed as +follows: + +.nf + cl> response quartz[10:20,*],quartz[35:45,*] \ + >>> quartz[12:18,*],quartz[12:18,*] resp,resp +.fi + +Generally the slit image sections are prepared in a file which is then +used to define the lists of input images and response. + +.nf + cl> response @slits @slits @responses +.fi + +3. If the DISPAXIS keyword is missing and the dispersion is running +vertically (varying with the image lines): + +.nf + cl> hedit *.imh dispaxis 2 add+ +.fi +.ih +SEE ALSO +icfit, iillumination +.endhelp diff --git a/noao/twodspec/longslit/doc/transform.hlp b/noao/twodspec/longslit/doc/transform.hlp new file mode 100644 index 00000000..6955b51e --- /dev/null +++ b/noao/twodspec/longslit/doc/transform.hlp @@ -0,0 +1,240 @@ +.help transform Sep87 noao.twodspec.longslit +.ih +NAME +transform -- Transform longslit images to user coordinates +.ih +USAGE +transform input output fitnames +.ih +PARAMETERS +.ls input +List of input images to be transformed. +.le +.ls output +List of output images. The number of output images in the list must +match the number of input images. +.le +.ls minput = "" +List of input masks or references. This mask is used to create an output +mask and is currently not used in the calculation of the output pixel +values. The list may be empty, a single element to apply to all input +images, or a list that matches the input list. A element in the list +may be "BPM" to use the mask referenced by the standard bad pixel mask +keyword "BPM", "!<keyword>" to use another header keyword pointing to a +mask, or a mask filename. The mask file is typically a pixel list file +but it may also be an image. The mask values are interpreted as zero and +greater than zero with the actual values ignored. The mask is assumed to +be registered with the input and no coordinate system matching is used. +The mask maybe smaller or larger than the input image with non-overlapping +pixels ignored and missing pixels assumed to be zero valued. The mask +.le +.ls moutput = "" +List of output masks to be created. The list may be empty or must match +the input list. Output masks may be specified even if no input mask is +specified, in which case the output mask will identify pixels which map +to regions outside the input images (also see the \fIblank\fR parameter). +If an explicit extension is not specified a FITS mask is extension is +created unless the environment variable "masktype" is set to "pl". +.le +.ls fitnames +Names of the user coordinate maps in the database to be used in the transform. +If no names are specified, using the null string "", the world coordinate +system (WCS) of the image is used. This latter case may be used to +resample previously WCS calibrated images to a different linear range +or sampling. +.le +.ls database = "database" +Database containing the coordinate map to be used in transforming the images. +.le +.ls interptype = "spline3" +Image interpolation type. The allowed types are "nearest" (nearest neighbor), +"linear" (bilinear), "poly3" (bicubic polynomial), "poly5" (biquintic +polynomial), and "spline3" (bicubic polynomial). +.le +.ls flux = yes +Conserve flux per pixel? If "no" then each output pixel is simply interpolated +from the input image. If "yes" the interpolated output pixel value is +multiplied by the Jacobean of the transformation (essentially the ratio of +pixel areas between the output and input images). +.le +.ls x1 = INDEF, y1 = INDEF +User coordinates of the first output column and line. If INDEF then the +smallest value corresponding to a pixel from the image used to create the +coordinate map is used. These values are in user units regardless of whether +logarithmic intervals are specified or not. +.le +.ls x2 = INDEF, y2 = INDEF +User coordinates of the last output column and line. If INDEF then the +largest value corresponding to a pixel from the image used to create the +coordinate map is used. These values are in user units regardless of whether +logarithmic intervals are specified or not. +.le +.ls dx = INDEF, dy = INDEF +Output pixel intervals. If INDEF then the interval is set to yield the +specified number of pixels. Note that for logarithmic intervals the +interval must be specified as a base 10 logarithm (base 10) and not in +user units. +.le +.ls nx = INDEF, ny = INDEF +Number of output pixels. If INDEF and if the pixel interval is also INDEF then +the number of output pixels is equal to the number of input pixels. +.le +.ls xlog = no, ylog = no +Convert to logarithmic intervals? If "yes" the output pixel intervals +are logarithmic. +.le +.ls blank = INDEF +Value to put in the output transformed image when it transforms to regions +outside the input image. The special value INDEF will use the nearest +input pixel which is the behavior before the addition of this parameter. +Using special blank values allows other software to identify such out +of input pixels. See also the \fImoutput\fR parameter to identify +out of input pixels in pixel masks. +.le +.ls logfiles = "STDOUT,logfile" +List of files in which to keep a log. If null, "", then no log is kept. +.le +.ih +DESCRIPTION +The coordinate maps U(X,Y) and V(X,Y), created by the task \fBfitcoords\fR, +are read from the specified database coordinate fits or from the +world coordinate system (WCS) of the image. X and Y are the original +untransformed pixel coordinates and U and V are the desired output user or +world coordinates (i.e. slit position and wavelength). If a coordinate map +for only one of the user coordinates is given then a one-to-one mapping +is assumed for the other such that U=X or V=Y. The coordinate maps are +inverted to obtain X(U,V) and Y(U,V) on an even subsampled grid of U and +V over the desired output image coordinates. The X and Y at each output +U and V used to interpolate from the input image are found by linear +interpolation over this grid. X(U,V) and Y(U,V) are not determined at +every output point because this is quite slow and is not necessary since +the coordinate surfaces are relatively slowly varying over the subsampling +(every 10th output point). + +The type of image interpolation is +selected by the user. Note that the more accurate the interpolator the +longer the transformation time required. The parameter \fIflux\fR selects +between direct image interpolation and a flux conserving interpolation. +Flux conservation consists of multiplying the interpolated pixel value by +the Jacobean of the transformation at that point. This is essentially +the ratio of the pixel areas between the output and input images. Note +that this is not exact since it is not an integral over the output pixel. +However, it will be very close except when the output pixel size is much +greater than the input pixel size. A log describing the image transformations +may be kept or printed on the standard output. + +The output coordinate grid may be defined by the user or allowed to +default to an image of the same size as the input image spanning the +full range of user coordinates in the coordinate transformation maps. +When the coordinate maps are created by the task \fBfitcoords\fR the +user coordinates at the corners of the image are recorded in the +database. By default these values are used to set the limits of the +output grid. If a pixel interval is not specified then an interval +yielding the specified number of pixels is used. The default number of +pixels is that of the input image. Note that if a pixel interval is +specified then it takes precedence over the number of pixels. + +The pixel intervals may also be logarithmic if the parameter \fIxlog\fR or +\fIylog\fR is "yes". Generally, the number of output pixels is specified +in this case . However, if the interval is specified it must be a base +10 logarithmic interval and not in units of the x and y limits which are +specified in user units. + +The transformation from the desired output pixel to the input image may +fall outside of the input image. In this case the output pixel may be +set to the nearest pixel value in the input image or to a particular value +using the \fIblank\fR parameter. Also if an output mask is created this +pixels will have a value of one in the mask. + +The parameters \fIminput\fR and \fImoutput\fR provide for input and output +pixel masks. An input mask is not used in calculating the transformed +pixel value but is used to identify the output pixels in the output mask +which make a significant contribution to the interpolated value. The +significance is determined as follows. The input mask values above zero +are converted to one hundred. The mask is then interpolated in the same +way as the input image. Any interpolated value of ten or greater is then +given the value one in the output mask. This means if all the input pixels +had mask values of zero a result of zero means no bad pixels were used. +If all the input pixels had values of 100 then the result will be 100 and +the output mask will flag this as a bad pixel. Other values are produced +by a mixture of good and bad pixels weighted by the interpolation kernel. +The choice of 10% is purely empirical and gives an approximate identification +of significant affected pixels. +zero and +is created with values of 100 + +.ih +EXAMPLES +Arc calibration images were used to determine a two dimensional dispersion +map called dispmap. Stellar spectra were used to determine a two dimensional +distortion map call distort. These maps where made using the task +\fBfitcoords\fR. To transform a set of input images into linear wavelength +between 3800 and 6400 Angstroms (the user coordinate units) with a dispersion +of 3 Angstroms per pixel: + +.nf + cl> transform obj001,obj002 out001,out002 dispmap,distort \ + >>> y1=3800 y2=6400 dy=3 +.fi + +To use logarithmic intervals in the wavelength to yield the same number of +pixels in the output images as in the input images: + +.nf + cl> transform obj001,obj002 out001,out002 dispmap,distort \ + >>> y1=3800 y2=6400 ylog=yes +.fi +.ih +TIMINGS +The following timings were obtained for transforming a 511x512 real +image to another 511x512 real image using two Chebyshev transformation +surface functions (one for the dispersion axis, "henear", and one in +spatial axis, "object") of order 6 in both dimensions created with the +task \fBfitcoords\fR. The times are for a UNIX/VAX 11/750. + +.nf +cl> $transform input output henear,object interp=linear +TIME (transform) 173.73 5:13 55% +cl> $transform input output henear,object interp=poly3 +TIME (transform) 266.63 9:17 42% +cl> $transform input output henear,object interp=spline3 +TIME (transform) 309.05 6:11 83% +cl> $transform input output henear,object interp=spline3 +TIME (transform) 444.13 9:44 76% +cl> $transform input output henear interp=linear +TIME (transform) 171.32 7:24 38% +cl> $transform input output henear interp=spline3 +TIME (transform) 303.40 12:17 41% +cl> $transform input output henear,object interp=spline3 flux=no +TIME (transform) 262.42 10:42 40% +.fi + +The majority of the time is due to the image interpolation and not evaluating +the transformation functions as indicated by the last three examples. +.ih +NOTES +.ls TRANSFORM: V2.12.2 +The use of bad pixel masks, a specified "blank" value, and use of a WCS +to resample a WCS calibrated image was added. +.le +.ls TRANSFORM: V2.6 +With Version 2.6 of IRAF the algorithm used to invert the user +coordinate surfaces, U(X,Y) and V(X,Y) to X(U,V) and Y(U,V), has been +changed. Previously surfaces of comparable order to the original +surfaces were fit to a grid of points, i.e. (U(X,Y), V(X,Y), X) and +(U(X,Y), V(X,Y), Y), with the same surface fitting routines used in +\fBfitcoords\fR to obtain the input user coordinate surfaces. This +method of inversion worked well in all cases in which reasonable +distortions and dispersions were used. It was selected because it was +relatively fast. However, it cannot be proved to work in all cases; in +one instance in which an invalid surface was used the inversion was +actually much poorer than expected. Therefore a more direct iterative +inversion algorithm is now used. This is guaranteed to give the +correct inversion to within a set error (0.05 of a pixel in X and Y). +It is slightly slower than the previous algorithm but it is still not +as major a factor as the image interpolation itself. +.le +.ih +SEE ALSO +fitcoords +.endhelp diff --git a/noao/twodspec/longslit/extinction.par b/noao/twodspec/longslit/extinction.par new file mode 100644 index 00000000..544802a8 --- /dev/null +++ b/noao/twodspec/longslit/extinction.par @@ -0,0 +1,5 @@ +# Parameter file for task extinct. + +input,s,a,,,,Images to be extinction corrected +output,s,a,,,,Extinction corrected images +extinction,f,h,onedstds$kpnoextinct.dat,,,Extinction file diff --git a/noao/twodspec/longslit/extinction.x b/noao/twodspec/longslit/extinction.x new file mode 100644 index 00000000..b3358303 --- /dev/null +++ b/noao/twodspec/longslit/extinction.x @@ -0,0 +1,226 @@ +include <imhdr.h> +include <error.h> + + +# T_EXTINCTION -- CL task for applying extinction corrections to images. +# +# The image headers must contain the parameters DISPAXIS, CRVALn, +# CRPIXn, and CDELTn to define the wavelength coordinates and +# either AIRMASS, ZD, or information needed to compute the zenith +# distance (HA, LATITUDE, RA, DEC, ST). +# +# The extinction table contains wavelengths and extinctions in +# magnitudes such that the multiplicative extinction correction +# is given by: +# +# correction = 10 ** (0.4 * airmass * extinction value) +# +# The extinction table need not be sorted. + + +procedure t_extinction() + +int list1 # List of images to be corrected +int list2 # List of extinction corrected images +char table[SZ_FNAME] # Extinction table filename + +bool extcor +char image1[SZ_FNAME], image2[SZ_FNAME] +int fd, nalloc, len_table +real wavelen, ext +pointer im1, im2, w, e + +int clpopnu(), fscan(), nscan(), open(), clgfil() +bool imgetb(), streq() +pointer immap() + +errchk ext_cor() + +begin + # Get the list of images and the extinction table. + + list1 = clpopnu ("input") + list2 = clpopnu ("output") + call clgstr ("extinction", table, SZ_FNAME) + + # Read the extinction table. Dynamically allocate memory for the + # table. + + fd = open (table, READ_ONLY, TEXT_FILE) + nalloc = 100 + call malloc (w, nalloc, TY_REAL) + call malloc (e, nalloc, TY_REAL) + + len_table = 0 + while (fscan (fd) != EOF) { + call gargr (wavelen) + call gargr (ext) + if (nscan() < 2) + next + + if (len_table == nalloc) { + nalloc = nalloc + 100 + call realloc (w, nalloc, TY_REAL) + call realloc (e, nalloc, TY_REAL) + } + + Memr[w + len_table] = wavelen + Memr[e + len_table] = ext + len_table = len_table + 1 + } + call close (fd) + + # If there are no extinction values in the table then return an error. + # Sort the extinction values by wavelength. + + if (len_table > 0) { + call realloc (w, len_table, TY_REAL) + call realloc (e, len_table, TY_REAL) + call xt_sort2 (Memr[w], Memr[e], len_table) + } else { + call mfree (w, TY_REAL) + call mfree (e, TY_REAL) + call error (0, "No extinction values extinction table") + } + + # Loop through each pair of input and output images. Check if + # the input image has been corrected previously. If TRUE then + # print message and go on to the next input image. If FALSE + # print message and apply extinction corrections. + # Missing information in the image header will return an error + # which will warn the user and go on to the next image. + + while (clgfil (list1, image1, SZ_FNAME) != EOF) { + + if (clgfil (list2, image2, SZ_FNAME) == EOF) { + call eprintf ("No output image for %s.\n") + call pargstr (image1) + next + } + + if (streq (image1, image2)) { + im1 = immap (image1, READ_WRITE, 0) + im2 = im1 + } else { + im1 = immap (image1, READ_ONLY, 0) + im2 = immap (image2, NEW_COPY, im1) + } + + iferr (extcor = imgetb (im1, "extcor")) + extcor = false + + if (extcor) { + call printf ("Image %s is extinction corrected.\n") + call pargstr (image1) + } else { + call printf ("Extinction correction: %s -> %s.\n") + call pargstr (image1) + call pargstr (image2) + call flush (STDOUT) + iferr (call do_extinct(im1, im2, Memr[w], Memr[e], len_table)) { + call printf ("!!No extinction correction for %s!!\n") + call pargstr (image1) + call flush (STDOUT) + call erract (EA_WARN) + } + } + + if (im2 != im1) + call imunmap (im2) + call imunmap (im1) + } + + # Finish up. + + call mfree (w, TY_REAL) + call mfree (e, TY_REAL) + call clpcls (list1) + call clpcls (list2) +end + + +# DO_EXTINCT -- Apply extinction correction. + +define SZ_FIELD 8 # Size of field string + +procedure do_extinct (im1, im2, w, e, len_table) + +pointer im1 # Input IMIO pointer +pointer im2 # Output IMIO pointer +real w[len_table] # Wavelengths +real e[len_table] # Extinction values +int len_table # Length of extinction table + +char field[SZ_FIELD] +int laxis, paxis, npix, i, flag, dcflag +real crval, cdelt, crpix, airmass, wavelen, extval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer sp, ext, pix1, pix2 + +int imgeti(), imgnlr(), impnlr() +real imgetr(), img_airmass() +errchk get_daxis, imgeti, imgetr, img_airmass + +begin + # Determine the dispersion axis and linear coordinates. + call get_daxis (im1, laxis, paxis) + + call sprintf (field, SZ_FIELD, "crval%d") + call pargi (laxis) + crval = imgetr (im1, field) + call sprintf (field, SZ_FIELD, "crpix%d") + call pargi (laxis) + crpix = imgetr (im1, field) + call sprintf (field, SZ_FIELD, "cdelt%d") + call pargi (laxis) + iferr (cdelt = imgetr (im1, field)) { + call sprintf (field, SZ_FIELD, "cd%d_%d") + call pargi (laxis) + call pargi (laxis) + cdelt = imgetr (im1, field) + } + dcflag = imgeti (im1, "dc-flag") + + # Determine the airmass. + + airmass = img_airmass (im1) + + # Determine the extinction values at each pixel. + + npix = IM_LEN (im1, laxis) + call smark (sp) + call salloc (ext, npix, TY_REAL) + + do i = 1, npix { + wavelen = crval + (i - crpix) * cdelt + if (dcflag == 1) + wavelen = 10. ** wavelen + call intrp (1, w, e, len_table, wavelen, extval, flag) + Memr[ext+i-1] = 10. ** (0.4 * airmass * extval) + } + + # Loop through the image applying the extinction correction to each + # pixel. + + call amovkl (long (1), v1, IM_MAXDIM) + call amovkl (long (1), v2, IM_MAXDIM) + while ((imgnlr(im1, pix1, v1) != EOF) && + (impnlr(im2, pix2, v2) != EOF)) { + switch (laxis) { + case 1: + call amulr (Memr[pix1], Memr[ext], Memr[pix2], IM_LEN (im1, 1)) + default: + extval = Memr[ext+v1[laxis]-2] + call amulkr (Memr[pix1], extval, Memr[pix2], IM_LEN (im1, 1)) + } + } + + call sfree (sp) + + # Add the extinction correction flag, history, and return. + # The parameter ex-flag is added for compatibility with onedspec. + + call imaddb (im2, "extcor", true) + call imaddi (im2, "ex-flag", 0) + call xt_phistory (im2, "Extinction correction applied.") +end diff --git a/noao/twodspec/longslit/fceval.par b/noao/twodspec/longslit/fceval.par new file mode 100644 index 00000000..0d9d8240 --- /dev/null +++ b/noao/twodspec/longslit/fceval.par @@ -0,0 +1,4 @@ +input,f,a,,,,Input coordinate file +output,f,a,,,,Output coordinate file +fitnames,s,a,,,,Names of coordinate fits in the database +database,f,h,database,,,Identify database diff --git a/noao/twodspec/longslit/fitcoords.par b/noao/twodspec/longslit/fitcoords.par new file mode 100644 index 00000000..ae203339 --- /dev/null +++ b/noao/twodspec/longslit/fitcoords.par @@ -0,0 +1,13 @@ +images,s,a,,,,Images whose coordinates are to be fit +fitname,s,h,"",,,Name for coordinate fit in the database +interactive,b,h,yes,,,Fit coordinates interactively? +combine,b,h,no,,,Combine input coordinates for a single fit? +database,f,h,database,,,Database +deletions,s,h,"deletions.db",,,Deletion list file (not used if null) +function,s,h,"chebyshev","chebyshev|legendre",,Type of fitting function +xorder,i,h,6,2,,X order of fitting function +yorder,i,h,6,2,,Y order of fitting function +logfiles,f,h,"STDOUT,logfile",,,Log files +plotfile,f,h,"plotfile",,,Plot log file +graphics,s,h,"stdgraph",,,Graphics output device +cursor,*gcur,h,"",,,Graphics cursor input diff --git a/noao/twodspec/longslit/fluxcalib.par b/noao/twodspec/longslit/fluxcalib.par new file mode 100644 index 00000000..b0612a6a --- /dev/null +++ b/noao/twodspec/longslit/fluxcalib.par @@ -0,0 +1,7 @@ +# Parameter file for FLUXCALIB + +input,s,a,,,,Images to be flux calibrated +output,s,a,,,,Flux calibrated images +fluxfile,f,a,,,,Flux calibration file +fnu,b,h,no,,,Flux in units of F-nu? +exposure,s,h,otime,,,Exposure time keyword in image headers diff --git a/noao/twodspec/longslit/fluxcalib.x b/noao/twodspec/longslit/fluxcalib.x new file mode 100644 index 00000000..042e7b89 --- /dev/null +++ b/noao/twodspec/longslit/fluxcalib.x @@ -0,0 +1,302 @@ +include <error.h> +include <imhdr.h> +include <math/iminterp.h> + +# T_FLUXCALIB -- CL task for applying flux calibration to longslit images. +# +# The image headers must contain the parameters DISPAXIS, W0, and WPC +# to define the wavelength coordinates in Angstroms and an exposure time +# in seconds. +# +# The flux file is an image containing sensitivity corrections in magnitudes: +# +# 2.5 log10 ((counts/sec/Ang) / (ergs/cm2/sec/Ang)) +# +# The flux file wavelengths need not be the same as the image but must +# span the entire range of the input image. If interpolation is required +# the interpolator is a cubic spline. + +procedure t_fluxcalib() + +int list1 # List of images to be calibrated +int list2 # List of calibrated images +char fluxfile[SZ_FNAME] # Name of flux file +bool fnu # Convert to fnu? + +char image1[SZ_FNAME], image2[SZ_FNAME], history[SZ_LINE] +bool fluxcor +pointer im1, im2, ff, fluxdata + +int imtopen(), imtgetim() +bool clgetb(), imgetb(), streq() +pointer immap() +errchk get_fluxdata(), do_fluxcalib() + +data fluxdata/NULL/ + +begin + # Get task parameters. + + call clgstr ("input", history, SZ_LINE) + list1 = imtopen (history) + call clgstr ("output", history, SZ_LINE) + list2 = imtopen (history) + call clgstr ("fluxfile", fluxfile, SZ_FNAME) + fnu = clgetb ("fnu") + ff = immap (fluxfile, READ_ONLY, 0) + + # Loop through each pair of input and output images. Check if the + # input image has been corrected previously. If TRUE then print + # message and go on to the next input image. If FALSE print message + # and apply flux corrections. Missing information in the image header + # will return an error which will warn the user and go on to the next + # image. + + while ((imtgetim (list1, image1, SZ_FNAME) != EOF) && + (imtgetim (list2, image2, SZ_FNAME) != EOF)) { + + # Open image to be calibrated. + iferr (im1 = immap (image1, READ_WRITE, 0)) { + call erract (EA_WARN) + next + } + + # Check if the image has already been flux calibrated. + iferr (fluxcor = imgetb (im1, "fluxcor")) + fluxcor = false + if (fluxcor) { + call printf ("Image %s is flux calibrated.\n") + call pargstr (image1) + call imunmap (im1) + next + } + + # Open output image + if (streq (image1, image2)) + im2 = immap ("fluxcalibtemp", NEW_COPY, im1) + else + im2 = immap (image2, NEW_COPY, im1) + IM_PIXTYPE(im2) = TY_REAL + + # Apply flux calibration. If error delete output image. + iferr { + call printf ("Flux calibration: %s --> %s.\n") + call pargstr (image1) + call pargstr (image2) + call flush (STDOUT) + call get_fluxdata (im1, ff, fnu, fluxdata) + call do_fluxcalib (im1, im2, Memr[fluxdata]) + call sprintf (history, SZ_LINE, + "Flux calibration %s applied with fnu=%b.") + call pargstr (fluxfile) + call pargb (fnu) + call xt_phistory (im2, history) + call imunmap (im2) + call imunmap (im1) + if (streq (image1, image2)) { + call imdelete (image1) + call imrename ("fluxcalibtemp", image1) + } + } then { + call imunmap (im2) + call imunmap (im1) + call imdelete (image2) + call printf ("!!No flux calibration for %s!!\n") + call pargstr (image1) + call flush (STDOUT) + call erract (EA_WARN) + } + } + + call mfree (fluxdata, TY_REAL) + call imunmap (ff) + call imtclose (list1) + call imtclose (list2) +end + + +# GET_FLUXDATA -- Get the flux calibration data for the mapped image. +# For efficiency read the data from the flux file only once and interpolate +# to the wavelengths of the image only if they differ from those of the +# flux file. Correct for the dispersion and exposure time of the image +# and convert to fnu if needed. + +procedure get_fluxdata (im, ff, fnu, fluxdata) + +pointer im # IMIO pointer for image to be calibrated +pointer ff # IMIO pointer for the flux file +bool fnu # Convert to fnu? +pointer fluxdata # Pointer to flux data + +int i, laxis, paxis, nw, ff_nw, ff_dcflag, dcflag +char exposure[SZ_LINE] +real w, dw, w0, wpc, crpix, exptime, ff_w0, ff_wpc +pointer ff_data, wavelens, asi + +int imgeti() +real imgetr() +pointer imgl1r() +errchk imgeti, imgetr + +define VLIGHT 2.997925e18 # Speed of light in Angstroms/sec + +begin + # If the fluxdata pointer is NULL then initialize. + + if (fluxdata == NULL) { + # Determine the dispersion. + + ff_dcflag = imgeti (ff, "dc-flag") + ff_w0 = imgetr (ff, "crval1") + iferr (ff_wpc = imgetr (ff, "cdelt1")) + ff_wpc = imgetr (ff, "cd1_1") + crpix = imgetr (ff, "crpix1") + ff_w0 = ff_w0 + (1 - crpix) * ff_wpc + ff_nw = IM_LEN (ff, 1) + + # Read the flux file and convert to multiplicative correction. + + ff_data = imgl1r (ff) + do i = ff_data, ff_data + ff_nw - 1 + Memr[i] = 10.0 ** (-0.4 * Memr[i]) + } + + # Determine dispersion and exposure time for the image. + call get_daxis (im, laxis, paxis) + dcflag = imgeti (im, "dc-flag") + if (laxis == 1) { + w0 = imgetr (im, "crval1") + iferr (wpc = imgetr (im, "cdelt1")) + wpc = imgetr (im, "cd1_1") + crpix = imgetr (im, "crpix1") + } else { + w0 = imgetr (im, "crval2") + iferr (wpc = imgetr (im, "cdelt2")) + wpc = imgetr (im, "cd2_2") + crpix = imgetr (im, "crpix2") + } + w0 = w0 + (1 - crpix) * wpc + nw = IM_LEN (im, laxis) + call clgstr ("exposure", exposure, SZ_LINE) + exptime = imgetr (im, exposure) + if (exptime <= 0.) + call error (0, "Bad integration time in image header") + + # Allocate memory for the flux calibration data. + + call mfree (fluxdata, TY_REAL) + call malloc (fluxdata, nw, TY_REAL) + + # Check if the data from the flux file needs to be interpolated. + + if ((w0 != ff_w0) || (wpc != ff_wpc) || (nw != ff_nw)) { + # Compute the interpolation wavelengths. + + call malloc (wavelens, nw, TY_REAL) + if ((ff_dcflag == 1) && (dcflag == 0)) + do i = 1, nw + Memr[wavelens+i-1] = (log10 (w0+(i-1)*wpc) - ff_w0) / + ff_wpc + 1 + else if ((ff_dcflag == 0) && (dcflag == 1)) + do i = 1, nw + Memr[wavelens+i-1] = (10. ** (w0+(i-1)*wpc) - ff_w0) / + ff_wpc + 1 + else + do i = 1, nw + Memr[wavelens+i-1] = ((w0+(i-1)*wpc) - ff_w0) / ff_wpc + 1 + + if ((Memr[wavelens] < 1.) || (Memr[wavelens+nw-1] > ff_nw)) { + if ((Memr[wavelens]<0.5) || (Memr[wavelens+nw-1]>ff_nw+0.5)) + call eprintf ( + "Warning: Wavelengths extend beyond flux calibration\n.") + call arltr (Memr[wavelens], nw, 1., 1.) + call argtr (Memr[wavelens], nw, real(ff_nw), real(ff_nw)) + } + + # Fit an interpolation cubic spline and evaluate. + + call asiinit (asi, II_SPLINE3) + call asifit (asi, Memr[ff_data], ff_nw) + call asivector (asi, Memr[wavelens], Memr[fluxdata], nw) + call asifree (asi) + call mfree (wavelens, TY_REAL) + } else + call amovr (Memr[ff_data], Memr[fluxdata], nw) + + # Convert to flux + + if (fnu) { + if (dcflag == 0) { + do i = 1, nw { + w = w0 + (i - 1) * wpc + dw = wpc + Memr[fluxdata+i-1] = Memr[fluxdata+i-1] / exptime / dw * + w**2 / VLIGHT + } + } else { + do i = 1, nw { + w = 10. ** (w0 + (i - 1) * wpc) + dw = 2.30259 * wpc * w + Memr[fluxdata+i-1] = Memr[fluxdata+i-1] / exptime / dw * + w**2 / VLIGHT + } + } + } else { + if (dcflag == 0) { + dw = wpc + call amulkr (Memr[fluxdata], 1./dw/exptime, Memr[fluxdata], nw) + } else { + do i = 1, nw { + dw = 2.30259 * wpc * (10. ** (w0 + (i - 1) * wpc)) + Memr[fluxdata+i-1] = Memr[fluxdata+i-1] / exptime / dw + } + } + } +end + + +# DO_FLUXCALIB -- Apply the flux calibration to a mapped image. +# This procedure works for images of any dimension. + +procedure do_fluxcalib (im1, im2, fluxdata) + +pointer im1 # IMIO pointer for image to be calibrated +pointer im2 # IMIO pointer for calibrated image +real fluxdata[ARB] # Flux calibration data + +int laxis, paxis, nw, npts +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer in, out + +int imgnlr(), impnlr() +errchk get_daxis + +begin + # Determine the dispersion axis of the image. + + call get_daxis (im1, laxis, paxis) + nw = IM_LEN (im1, laxis) + + # Calibrate the image. + + npts = IM_LEN (im1, 1) + call amovkl (long (1), v1, IM_MAXDIM) + call amovkl (long (1), v2, IM_MAXDIM) + + if (laxis == 1) { + while ((imgnlr(im1, in, v1) != EOF) && + (impnlr(im2, out, v2) != EOF)) + call amulr (Memr[in], fluxdata, Memr[out], npts) + + } else { + while ((imgnlr(im1, in, v1) != EOF) && + (impnlr(im2, out, v2) != EOF)) + call amulkr (Memr[in], fluxdata[v1[laxis]-1], Memr[out], + npts) + } + + # Add the flux correction flag and return. + + call imaddb (im2, "fluxcor", true) + call imaddi (im2, "ca-flag", 0) +end diff --git a/noao/twodspec/longslit/getdaxis.x b/noao/twodspec/longslit/getdaxis.x new file mode 100644 index 00000000..06be22c7 --- /dev/null +++ b/noao/twodspec/longslit/getdaxis.x @@ -0,0 +1,36 @@ +include <mwset.h> + + +# GET_DAXIS -- Get logical dispersion axis. + +procedure get_daxis (im, laxis, paxis) + +pointer im #I IMIO pointer +int laxis #O Logical dispersion axis +int paxis #O Physical dispersion axis + +real ltm[2,2], ltv[2] +pointer mw, tmp, mw_openim() +int imgeti(), clgeti() +errchk imaddi, mw_openim, mw_gltermr + +begin + # Get the dispersion axis from the header or package parameter. + iferr (paxis = imgeti (im, "dispaxis")) { + paxis = clgeti ("dispaxis") + call imaddi (im, "dispaxis", paxis) + } + laxis = paxis + + # Check for a transposed image. + iferr { + mw= NULL + tmp = mw_openim (im); mw = tmp + call mw_gltermr (mw, ltm, ltv, 2) + if (ltm[1,1] == 0. && ltm[2,2] == 0) + laxis = mod (paxis, 2) + 1 + } then + ; + if (mw != NULL) + call mw_close (mw) +end diff --git a/noao/twodspec/longslit/illumination.par b/noao/twodspec/longslit/illumination.par new file mode 100644 index 00000000..6c5792b1 --- /dev/null +++ b/noao/twodspec/longslit/illumination.par @@ -0,0 +1,18 @@ +# ILLUMINATION -- Determine illumination calibrations + +images,s,a,,,,Longslit calibration images +illuminations,s,a,,,,Illumination function images +interactive,b,h,yes,,,Interactive illumination fitting? +bins,s,h,"",,,Dispersion bins +nbins,i,h,5,1,,Number of dispersion bins when bins = "" +sample,s,h,"*",,,Sample of points to use in fit +naverage,i,h,1,,,Number of points in sample averaging +function,s,h,"spline3","spline3|legendre|chebyshev|spline1",,Fitting function +order,i,h,1,1,,Order of fitting function +low_reject,r,h,0.,0.,,Low rejection in sigma of fit +high_reject,r,h,0.,0.,,High rejection in sigma of fit +niterate,i,h,1,0,,Number of rejection iterations +grow,r,h,0.,0.,,Rejection growing radius +interpolator,s,h,"poly3","nearest|linear|poly3|poly5|spline3",,Interpolation type +graphics,s,h,"stdgraph",,,Graphics output device +cursor,*gcur,h,"",,,Graphics cursor input diff --git a/noao/twodspec/longslit/illumination.x b/noao/twodspec/longslit/illumination.x new file mode 100644 index 00000000..c291d6f4 --- /dev/null +++ b/noao/twodspec/longslit/illumination.x @@ -0,0 +1,414 @@ +include <imhdr.h> +include <error.h> +include <math/iminterp.h> +include <pkg/gtools.h> +include <pkg/rg.h> +include <pkg/xtanswer.h> + +# T_ILLUMINATION -- Determine the illumination function for longslit spectra. +# +# The calibration image is binned in wavelength. Each wavelength bin is +# then smoothed by curve fitting and normalized to the middle point. +# Finally the binned image is interpolated back to the original image +# dimension. The binning and curve fitting may be performed interactively. +# A illumination function is determined for each input images. Image +# sections in the input image allow only parts of the illumination function +# to be created. Thus, multiple slits in the same image may have +# independent illumination functions on the same illumination image. + +# CL callable procedure. +# +# The input and output images are given by image templates. The +# number of output images must match the number of input images. +# Input image sections are allowed. + +procedure t_illumination () + +pointer image1 +pointer image2 +int list1 # Calibration image list +int list2 # Illumination image list +int interactive # Interactive? +int naverage # Sample averaging size +int order # Order of curve fitting function +real low_reject, high_reject # Rejection thresholds +int niterate # Number of rejection iterations +real grow # Rejection growing radius + +int answer +char history[SZ_LINE] +pointer in, out, ic, gt, sp, str + +int clgeti(), imtopen(), imtgetim(), imtlen(), gt_init() +bool clgetb() +real clgetr() +errchk il_make + +begin + call smark (sp) + call salloc (image1, SZ_LINE, TY_CHAR) + call salloc (image2, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get calibration and illumination image template lists. + + call clgstr ("images", Memc[image1], SZ_LINE) + call clgstr ("illuminations", Memc[image2], SZ_LINE) + + # Check that the number of illumination calibration images are the same. + + list1 = imtopen (Memc[image1]) + list2 = imtopen (Memc[image2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, + "The number of input and output images are not the same.") + } + + # Get other parameters and initialize the curve fitting package. + + if (clgetb ("interactive")) + interactive = YES + else + interactive = ALWAYSNO + + call clgstr ("sample", Memc[image1], SZ_LINE) + naverage = clgeti ("naverage") + call clgstr ("function", Memc[str], SZ_LINE) + order = clgeti ("order") + low_reject = clgetr ("low_reject") + high_reject = clgetr ("high_reject") + niterate = clgeti ("niterate") + grow = clgetr ("grow") + + # Set the ICFIT pointer structure. + call ic_open (ic) + call ic_pstr (ic, "sample", Memc[image1]) + call ic_puti (ic, "naverage", naverage) + call ic_pstr (ic, "function", Memc[str]) + call ic_puti (ic, "order", order) + call ic_putr (ic, "low", low_reject) + call ic_putr (ic, "high", high_reject) + call ic_puti (ic, "niterate", niterate) + call ic_putr (ic, "grow", grow) + call ic_pstr (ic, "ylabel", "") + + gt = gt_init() + call gt_sets (gt, GTTYPE, "line") + + # Create an illumination image for each calibration image + while ((imtgetim (list1, Memc[image1], SZ_LINE) != EOF) && + (imtgetim (list2, Memc[image2], SZ_LINE) != EOF)) { + + call ls_immap (Memc[image1], Memc[image2], in, out) + + call sprintf (Memc[str], SZ_LINE, + "Determine illumination interactively for %s") + call pargstr (Memc[image1]) + call xt_answer (Memc[str], interactive) + answer = interactive + + iferr { + call il_make (in, out, ic, gt, Memc[str], answer) + + call imaddr (out, "ccdmean", 1.) + call sprintf (history, SZ_LINE, + "Illumination correction determined from %s.") + call pargstr (Memc[image1]) + call imastr (out, "mkillum", history) + call imunmap (in) + call imunmap (out) + } then { + call erract (EA_WARN) + call imunmap (in) + call imunmap (out) + call imdelete (Memc[image2]) + } + } + + call ic_closer (ic) + call gt_free (gt) + call imtclose (list1) + call imtclose (list2) + call sfree (sp) +end + + +# IL_MAKE -- Given the calibration and illumination image descriptors +# make the illumination function. + +procedure il_make (in, out, ic, gt, title, interactive) + +pointer in # Calibration IMIO pointer +pointer out # Illumination IMIO pointer +pointer ic # ICFIT pointer +pointer gt # GTOOLS pointer +char title[ARB] # Title +int interactive # Interactive? + +char graphics[SZ_FNAME] # Graphics output device +int i, laxis, paxis, axis, npts, nbins, len_title +pointer bins, cv, gp, sp, x, y, z, z1, wts + +pointer gopen() +int strlen() +errchk get_daxis + +begin + # Determine the slit axis and set the axis labels. + call get_daxis (in, laxis, paxis) + if (laxis == 1) + axis = 2 + else + axis = 1 + + switch (axis) { + case 1: + call ic_pstr (ic, "xlabel", "Column") + case 2: + call ic_pstr (ic, "xlabel", "Line") + } + + # Set the bins and bin the calibration image. + + switch (axis) { + case 1: + call il_setbins (in, 2, interactive, bins) + case 2: + call il_setbins (in, 1, interactive, bins) + } + + call il_binimage (in, axis, bins, x, y, z, npts, nbins) + call rg_free (bins) + + # Allocate memory for the fit. + + call smark (sp) + call salloc (wts, npts, TY_REAL) + call amovkr (1., Memr[wts], npts) + + # Smooth each bin. + + call ic_putr (ic, "xmin", Memr[x]) + call ic_putr (ic, "xmax", Memr[x+npts-1]) + + len_title = strlen (title) + z1 = z + + do i = 1, nbins { + title[len_title + 1] = EOS + call sprintf (title, SZ_LINE, "%s at bin %d") + call pargstr (title) + call pargi (i) + call xt_answer (title, interactive) + + if ((interactive == YES) || (interactive == ALWAYSYES)) { + call sprintf (title, SZ_LINE, "%s\n%s") + call pargstr (title) + call pargstr (IM_TITLE(in)) + call gt_sets (gt, GTTITLE, title) + + call clgstr ("graphics", graphics, SZ_FNAME) + gp = gopen (graphics, NEW_FILE, STDGRAPH) + call icg_fit (ic, gp, "cursor", gt, cv, Memr[x], Memr[z1], + Memr[wts], npts) + call amovkr (1., Memr[wts], npts) + call gclose (gp) + } else { + call ic_fit (ic, cv, Memr[x], Memr[z1], Memr[wts], npts, + YES, YES, YES, YES) + } + + call cvvector (cv, Memr[x], Memr[z1], npts) + z1 = z1 + npts + } + call cvfree (cv) + + # Compute the illumination image by linear interpolation. + + call il_expand (out, axis, Memr[x], Memr[y], Memr[z], npts, nbins) + + # Free allocated memory. + + call mfree (x, TY_REAL) + call mfree (y, TY_REAL) + call mfree (z, TY_REAL) + call sfree (sp) +end + + +# IL_BINIMAGE -- Read the calibration image and bin it. + +procedure il_binimage (im, axis, bins, x, y, z, npts, nbins) + +pointer im # Calibration IMIO pointer +int axis # Slit axis +pointer bins # Bins +pointer x # Slit positions +pointer y # Dispersion positions of bins +pointer z # Binned image +int npts # Number of points per bin +int nbins # Number of bins + +int i, y1, y2 +pointer z1 + +begin + # Allocate memory. + + npts = IM_LEN (im, axis) + nbins = RG_NRGS (bins) + call malloc (y, nbins, TY_REAL) + call malloc (z, npts * nbins, TY_REAL) + + # Bin the image data. + + x = NULL + do i = 1, nbins { + y1 = RG_X1 (bins, i) + y2 = RG_X2 (bins, i) + Memr[y+i-1] = (y1 + y2) / 2 + + call mfree (x, TY_REAL) + switch (axis) { + case 1: + call ls_aimavg (im, axis, 1, IM_LEN(im, 1), y1, y2, x, z1, npts) + case 2: + call ls_aimavg (im, axis, y1, y2, 1, IM_LEN(im, 2), x, z1, npts) + } + call amovr (Memr[z1], Memr[z+(i-1)*npts], npts) + call mfree (z1, TY_REAL) + } +end + + +# IL_EXPAND -- Expand the reduced illumination back to the original size. +# This procedure request the interpolation type. + +procedure il_expand (im, axis, x, y, z, nx, ny) + +pointer im # Illumination image pointer +int axis # Slit axis +real x[nx] # Slit coordinates +real y[ny] # Dispersion coordinates +real z[nx, ny] # Slit profile +int nx # Number of points per slit profile +int ny # Number of slit profiles + +char dummy[7] +int nyout, ncols, nlines +int i, j, y1, y2 +real dy +pointer msi, sp, out, yout + +int clgwrd() +pointer impl2r() + +int msitypes[5] +data msitypes/II_BINEAREST,II_BILINEAR,II_BIPOLY3,II_BIPOLY5,II_BISPLINE3/ +string msinames "|nearest|linear|poly3|poly5|spline3|" + +begin + ncols = IM_LEN (im, 1) + nlines = IM_LEN (im, 2) + + # Normalize illumination to the center of each slit. + + i = nx / 2 - 1 + do j = 1, ny { + dy = z[i, j] + call adivkr (z[1, j], dy, z[1, j], nx) + } + + # If there is only one slit profile then copy the profile to each + # image line or column. + + if (ny == 1) { + switch (axis) { + case 1: + do i = 1, nlines + call amovr (z, Memr[impl2r (im, i)], ncols) + case 2: + do i = 1, nlines + call amovkr (z[i, 1], Memr[impl2r (im, i)], ncols) + } + + return + } + + # If there is more than one slit profile fit a 2D interpolator. + + i = clgwrd ("interpolator", dummy, 7, msinames) + if (i == 0) + i = II_BILINEAR + else + i = msitypes[i] + + switch (i) { + case II_POLY3, II_SPLINE3: + if (ny < 4) + i = II_BILINEAR + case II_POLY5: + if (ny < 6) { + if (ny < 4) + i = II_BILINEAR + else + i = II_POLY3 + } + } + + call msiinit (msi, i) + call msifit (msi, z, nx, ny, nx) + + # Set the output grid in terms of the interpolation surface. + + switch (axis) { + case 1: + nyout = IM_LEN (im, 2) + case 2: + nyout = IM_LEN (im, 1) + } + + call smark (sp) + call salloc (yout, nyout, TY_REAL) + + y1 = 1 + y2 = y[1] + do i = y1, y2 + Memr[yout+i-1] = 1 + do j = 2, ny { + y1 = y2 + 1 + y2 = y[j] + dy = 1. / (y2 - y1) + do i = y1, y2 + Memr[yout+i-1] = j - 1 + (i - y1) * dy + } + y1 = y2 + 1 + y2 = nyout + do i = y1, y2 + Memr[yout+i-1] = ny + + # Evaluate the interpolation surface on the output grid. + + ncols = IM_LEN (im, 1) + nlines = IM_LEN (im, 2) + call salloc (out, ncols, TY_REAL) + + switch (axis) { + case 1: + do i = 1, nlines { + call amovkr (Memr[yout+i-1], Memr[out], ncols) + call msivector (msi, x, Memr[out], Memr[impl2r (im, i)], + ncols) + } + case 2: + do i = 1, nlines { + call amovkr (x[i], Memr[out], ncols) + call msivector (msi, Memr[out], Memr[yout], Memr[impl2r(im, i)], + ncols) + } + } + + call sfree (sp) +end diff --git a/noao/twodspec/longslit/ilsetbins.x b/noao/twodspec/longslit/ilsetbins.x new file mode 100644 index 00000000..5d71a03a --- /dev/null +++ b/noao/twodspec/longslit/ilsetbins.x @@ -0,0 +1,232 @@ +include <imhdr.h> +include <gset.h> +include <pkg/rg.h> +include <pkg/gtools.h> +include <pkg/xtanswer.h> + +define HELP "noao$lib/scr/ilsetbins.key" +define PROMPT "illumination options" +define SZ_BINS 2048 # Length of bin string + +# IL_SETBINS -- Set the dispersion bins. + +procedure il_setbins (im, axis, interactive, rg) + +pointer im # IMIO pointer for calibration image +int axis # Slit axis +int interactive # Set bins interactively? +pointer rg # Range pointer for bins + +char bins[SZ_BINS], str[SZ_LINE] +int i, npts, nbins +real dx +pointer x + +int clgeti() +pointer rg_ranges() + +begin + # Get the bins. If the bin string is null then divide the dispersion + # range into a number of equal bins. + + call clgstr ("bins", bins, SZ_BINS) + call xt_stripwhite (bins) + + npts = IM_LEN (im, axis) + + if (bins[1] == EOS) { + call malloc (x, npts, TY_INT) + do i = 1, npts + Memi[x+i-1] = i + nbins = clgeti ("nbins") + dx = npts / nbins + do i = 1, nbins { + call sprintf (str, SZ_LINE, "%d:%d ") + call pargi (Memi[x + int ((i - 1) * dx)]) + call pargi (Memi[x + int (i * dx - 1)]) + call strcat (str, bins, SZ_BINS) + } + call mfree (x, TY_INT) + } + + rg = rg_ranges (bins, 1, npts) + if (rg == NULL) + call error (0, "Bad range string for parameter bins") + + # Set the bins interactively. + + if ((interactive == YES) || (interactive == ALWAYSYES)) { + call sprintf (str, SZ_LINE, "Set illumination bins\n%s") + call pargstr (IM_TITLE(im)) + call il_gsetbins (im, axis, str, bins, SZ_BINS, rg) + } + + call rg_order (rg) +end + + +# IL_GSETBINS -- Set dispersion bins graphically. + +procedure il_gsetbins (im, axis, title, bins, sz_bins, rg) + +pointer im # IMIO pointer +int axis # Slit axis +char title[ARB] # Title +char bins[sz_bins] # Bin string +int sz_bins # Size of bin string +pointer rg # Range pointer for the bins + +int npts, newbins, newgraph +real x1, x2 +char oldbins[SZ_BINS] +pointer gp, gt, x, y + +real wx, wy +int wcs, key +char cmd[SZ_BINS] + +int gt_gcur(), stridxs(), strlen() +pointer gopen(), gt_init(), rg_xrangesr() + +begin + # Get the average spectrum. + + call ls_aimavg (im, axis, 1, IM_LEN(im,1), 1, IM_LEN(im,2), x, y, npts) + + # Graph the spectrum and mark the bins. + + call clgstr ("graphics", oldbins, SZ_BINS) + gp = gopen (oldbins, NEW_FILE, STDGRAPH) + gt = gt_init() + call il_gbins (gp, gt, axis, Memr[x], Memr[y], npts, bins, title) + + while (gt_gcur ("cursor", wx, wy, wcs, key, cmd, SZ_BINS) != EOF) { + switch (key) { + case '?': # Print help text + call gpagefile (gp, HELP, PROMPT) + + case ':': # Colon commands + call strcpy (bins, oldbins, SZ_BINS) + if (cmd[1] == '/') + call gt_colon (cmd, gp, gt, newgraph) + else + call il_colon (cmd, bins, sz_bins, newbins) + if (newgraph == YES) { + call il_gbins (gp, gt, axis, Memr[x], Memr[y], npts, bins, + title) + } else if (newbins == YES) { + call rg_gxmarkr (gp, oldbins, Memr[x], npts, 0) + call rg_gxmarkr (gp, bins, Memr[x], npts, 1) + } + + case 'i': # Initialize range string + call rg_gxmarkr (gp, bins, Memr[x], npts, 0) + call sprintf (bins, sz_bins, "*") + + case 's': # Set sample ranges with the cursor. + if (stridxs ("*", bins) > 0) + bins[1] = EOS + + x1 = wx + call printf ("again:\n") + if (gt_gcur ("cursor", wx, wy, wcs, key, cmd, SZ_BINS) == EOF) + break + + x2 = wx + call sprintf (cmd, SZ_BINS, "%d:%d ") + call pargr (x1) + call pargr (x2) + if (strlen (cmd) + strlen (bins) > sz_bins) + call eprintf ( + "Warning: Too many bins. New bin ignored.\n") + else { + call strcat (cmd, bins, sz_bins) + call rg_gxmarkr (gp, bins, Memr[x], npts, 1) + } + + case 'I': + call fatal (0, "Interrupt") + + default: # Ring bell for unrecognized commands. + call printf ("\7\n") + } + } + + rg = rg_xrangesr (bins, Memr[x], npts) + + call mfree (x, TY_REAL) + call mfree (y, TY_REAL) + call gclose (gp) + call gt_free (gt) +end + + +define COMMANDS "|show|bins|" +define SHOW 1 # Show bins +define BINS 2 # Set bins + +# IL_COLON -- Processes colon commands. + +procedure il_colon (cmdstr, bins, sz_bins, newbins) + +char cmdstr[ARB] # Colon command +char bins[sz_bins] # Bins string +int sz_bins # Size of bins string +int newbins # New bins? + +char cmd[SZ_BINS] +int ncmd + +int strdic() + +begin + newbins = NO + + call sscan (cmdstr) + call gargwrd (cmd, SZ_BINS) + ncmd = strdic (cmd, cmd, SZ_BINS, COMMANDS) + + switch (ncmd) { + case SHOW: + call printf ("bins = %s\n") + call pargstr (bins) + case BINS: + call gargstr (cmd, SZ_BINS) + call xt_stripwhite (cmd) + if (cmd[1] == EOS) { + call printf ("bins = %s\n") + call pargstr (bins) + } else { + call strcpy (cmd, bins, sz_bins) + newbins = YES + } + } +end + + +# IL_GBINS -- Graph data + +procedure il_gbins (gp, gt, axis, x, y, npts, bins, title) + +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +int axis # Slit axis +real x[npts], y[npts] # Data to graph +int npts # Number of data points +char bins[ARB] # Bins to graph +char title[ARB] # Graph labels + +begin + call gclear (gp) + call gascale (gp, x, npts, 1) + call gascale (gp, y, npts, 2) + call gt_swind (gp, gt) + switch (axis) { + case 1: + call glabax (gp, title, "Line", "") + case 2: + call glabax (gp, title, "Column", "") + } + call gpline (gp, x, y, npts) + call rg_gxmarkr (gp, bins, x, npts, 1) +end diff --git a/noao/twodspec/longslit/longslit.cl b/noao/twodspec/longslit/longslit.cl new file mode 100644 index 00000000..4ba17770 --- /dev/null +++ b/noao/twodspec/longslit/longslit.cl @@ -0,0 +1,54 @@ +#{ LONGSLIT -- Longslit Package + +# Load dependent packages + +images # Used in setimhdr + +package longslit + +set generic = "noao$imred/generic/" +set demos = "longslit$demos/" + +# Tasks. + +task extinction, + fceval, + fitcoords, + fluxcalib, + illumination, + lscombine, + response, + transform = longslit$x_longslit.e + +task calibrate, + reidentify, + sensfunc, + standard = longslit$x_onedspec.e + +task autoidentify, + deredden, + dopcor, + identify, + lcalib, + sarith, + sflip, + slist, + specplot, + specshift, + splot = onedspec$x_onedspec.e + +task aidpars = onedspec$aidpars.par +task bplot = onedspec$bplot.cl +task scopy = onedspec$scopy.cl + +task background = generic$background.cl + +task setairmass, + setjd = astutil$x_astutil.e + +# Demos +task demos = demos$demos.cl + +hidetask slist + +clbye diff --git a/noao/twodspec/longslit/longslit.hd b/noao/twodspec/longslit/longslit.hd new file mode 100644 index 00000000..6f52233b --- /dev/null +++ b/noao/twodspec/longslit/longslit.hd @@ -0,0 +1,14 @@ +# Help directory for the LONGSLIT package. + +$doc = "./doc/" +$identify = "noao$onedspec/doc/" + +extinction hlp=doc$extinction.hlp +fceval hlp=doc$fceval.hlp +fitcoords hlp=doc$fitcoords.hlp +fluxcalib hlp=doc$fluxcalib.hlp +illumination hlp=doc$illumination.hlp +lscombine hlp=doc$lscombine.hlp +response hlp=doc$response.hlp +revisions sys=Revisions +transform hlp=doc$transform.hlp diff --git a/noao/twodspec/longslit/longslit.men b/noao/twodspec/longslit/longslit.men new file mode 100644 index 00000000..27dbb175 --- /dev/null +++ b/noao/twodspec/longslit/longslit.men @@ -0,0 +1,29 @@ + background - Fit and subtract a line or column background + bplot - Batch plots of spectra + calibrate - Apply extinction and flux calibrations to spectra + deredden - Apply interstellar extinction correction + dopcor - Apply doppler corrections + fceval - Evaluate coordinates using the FITSCOORDS solutions + fitcoords - Fit user coordinates to image coordinates + identify - Identify features + illumination - Determine illumination calibration + lcalib - List calibration file data + lscombine - Combine longslit images + reidentify - Reidentify features + response - Determine response calibration + sarith - Spectrum arithmetic + scopy - Sum and extract spectra from long slit to 1D format + sensfunc - Create sensitivity function + setairmass - Compute effective airmass and middle UT for an exposure + setjd - Compute and set Julian dates in images + sflip - Flip data and/or dispersion coordinates in spectra + specplot - Stack and plot multiple spectra + specshift - Shift spectral dispersion coordinate systems + splot - Preliminary spectral plot/analysis + standard - Identify standard stars to be used in sensitivity calc + transform - Transform longslit images to user coordinates + + extinction - Apply atmospheric extinction corrections to images (obsolete) + fluxcalib - Apply flux calibration to images (obsolete) + + demos - Demonstration and test playbacks diff --git a/noao/twodspec/longslit/longslit.par b/noao/twodspec/longslit/longslit.par new file mode 100644 index 00000000..c028f508 --- /dev/null +++ b/noao/twodspec/longslit/longslit.par @@ -0,0 +1,10 @@ +# LONGSLIT package parameter file. + +dispaxis,i,q,1,1,3,"Dispersion axis (1=along lines, 2=along columns, 3=along z)" +nsum,s,h,"1",,,"Number of lines/columns to sum " +observatory,s,h,"observatory",,,Observatory of data +extinction,s,h,onedstds$kpnoextinct.dat,,,Extinction file +caldir,s,h,onedstds$spec50cal/,,,Standard star calibration directory +interp,s,h,"poly5","nearest|linear|poly3|poly5|spline3|sinc",,Interpolation type +records,s,h,"",,,Record number extensions +version,s,h,"February 1993" diff --git a/noao/twodspec/longslit/lscombine.par b/noao/twodspec/longslit/lscombine.par new file mode 100644 index 00000000..d93e2387 --- /dev/null +++ b/noao/twodspec/longslit/lscombine.par @@ -0,0 +1,53 @@ +# LSCOMBINE -- Long slit combine parameters + +input,s,a,,,,List of images to combine +output,s,a,,,,Output image +headers,s,h,"",,,Output header file (optional) +bpmasks,s,h,"",,,Output bad pixel mask (optional) +rejmasks,s,h,"",,,Output rejection mask (optional) +nrejmasks,s,h,"",,,Output number rejected mask (optional) +expmasks,s,h,"",,,Output exposure mask (optional) +sigmas,s,h,"",,,Output sigma image (optional) +logfile,s,h,"STDOUT",,,"Log file +" +interptype,s,h,spline3,"nearest|linear|poly3|poly5|spline3",,Interpolation type +x1,r,h,INDEF,,,Output starting x coordinate +x2,r,h,INDEF,,,Output ending x coordinate +dx,r,h,INDEF,,,Output X pixel interval +nx,r,h,INDEF,,,Number of output x pixels +y1,r,h,INDEF,,,Output starting y coordinate +y2,r,h,INDEF,,,Output ending y coordinate +dy,r,h,INDEF,,,Output Y pixel interval +ny,r,h,INDEF,,,"Number of output y pixels +" +combine,s,h,"average","average|median|sum",,Type of combine operation +reject,s,h,"none","none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip",,Type of rejection +project,b,h,no,,,Project highest dimension of input images? +outtype,s,h,"real","none|short|ushort|integer|long|real|double",,Output image pixel datatype +outlimits,s,h,"",,,Output limits (x1 x2 y1 y2 ...) +masktype,s,h,"none","none|goodvalue",,Mask type +blank,r,h,0.,,,"Value if there are no pixels +" +scale,s,h,"none",,,Image scaling +zero,s,h,"none",,,Image zero point offset +weight,s,h,"none",,,Image weights +statsec,s,h,"",,,Image section for computing statistics +expname,s,h,"",,,"Image header exposure time keyword +" +lthreshold,r,h,INDEF,,,Lower threshold +hthreshold,r,h,INDEF,,,Upper threshold +nlow,i,h,1,0,,minmax: Number of low pixels to reject +nhigh,i,h,1,0,,minmax: Number of high pixels to reject +nkeep,i,h,1,,,Minimum to keep (pos) or maximum to reject (neg) +mclip,b,h,yes,,,Use median in sigma clipping algorithms? +lsigma,r,h,3.,0.,,Lower sigma clipping factor +hsigma,r,h,3.,0.,,Upper sigma clipping factor +rdnoise,s,h,"0.",,,ccdclip: CCD readout noise (electrons) +gain,s,h,"1.",,,ccdclip: CCD gain (electrons/DN) +snoise,s,h,"0.",,,ccdclip: Sensitivity noise (fraction) +sigscale,r,h,0.1,0.,,Tolerance for sigma clipping scaling corrections +pclip,r,h,-0.5,,,pclip: Percentile clipping parameter +grow,r,h,0.,0.,,"Radius (pixels) for neighbor rejection +" +offsets,f,h,"none","none" +maskvalue,r,h,0,0 diff --git a/noao/twodspec/longslit/lscombine/mkpkg b/noao/twodspec/longslit/lscombine/mkpkg new file mode 100644 index 00000000..c8d60229 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/mkpkg @@ -0,0 +1,14 @@ +# Make the LSCOMBINE Task. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + @src + + t_lscombine.x <error.h> <imhdr.h> <mach.h> <math/iminterp.h>\ + src/icombine.com src/icombine.h\ + ../transform/transform.com + ; diff --git a/noao/twodspec/longslit/lscombine/src/generic/icaclip.x b/noao/twodspec/longslit/lscombine/src/generic/icaclip.x new file mode 100644 index 00000000..97c12346 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icaclip.x @@ -0,0 +1,2206 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Minimum number of images for this algorithm + + +# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_aavsigclips (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, s1, r, one +data one /1.0/ +pointer sp, sums, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (sums, npts, TY_REAL) + call salloc (resid, nimages+1, TY_REAL) + + # Since the unweighted average is computed here possibly skip combining + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Compute the unweighted average with the high and low rejected and + # the poisson scaled average sigma. There must be at least three + # pixels at each point to define the average and contributions to + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + nin = n[1] + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 < 3) + next + + # Unweighted average with the high and low rejected + low = Mems[d[1]+k] + high = Mems[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mems[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Mems[dp1] + l = Memi[mp1] + s1 = max (one, (a + zeros[l]) / scales[l]) + s = s + (d1 - a) ** 2 / s1 + } + } else { + s1 = max (one, a) + do j = 1, n1 + s = s + (Mems[d[j]+k] - a) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the average and sum for later. + average[i] = a + Memr[sums+k] = sum + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + + # Reject pixels and compute the final average (if needed). + # There must be at least three pixels at each point for rejection. + # Iteratively scale the mean sigma and reject pixels + # Compact the data and keep track of the image IDs if needed. + + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (2, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mems[d[1]+k] + do j = 2, n1 + sum = sum + Mems[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + a = average[i] + sum = Memr[sums+k] + + repeat { + n2 = n1 + if (s > 0.) { + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Mems[dp1] + l = Memi[mp1] + s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + s1 = s * sqrt (max (one, a)) + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Mems[dp1] + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_mavsigclips (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +pointer sp, resid, mp1, mp2 +real med, low, high, r, s, s1, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute the poisson scaled average sigma about the median. + # There must be at least three pixels at each point to define + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + s = 0. + n2 = 0 + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 < 3) { + if (n1 == 0) + median[i] = blank + else if (n1 == 1) + median[i] = Mems[d[1]+k] + else { + low = Mems[d[1]+k] + high = Mems[d[2]+k] + median[i] = (low + high) / 2. + } + next + } + + # Median + n3 = 1 + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mems[d[n3-1]+k] + high = Mems[d[n3]+k] + med = (low + high) / 2. + } else + med = Mems[d[n3]+k] + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + l = Memi[m[j]+k] + s1 = max (one, (med + zeros[l]) / scales[l]) + s = s + (Mems[d[j]+k] - med) ** 2 / s1 + } + } else { + s1 = max (one, med) + do j = 1, n1 + s = s + (Mems[d[j]+k] - med) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the median for later. + median[i] = med + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 < max (3, maxkeep+1)) + next + nl = 1 + nh = n1 + med = median[i] + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 >= max (MINCLIP, maxkeep+1) && s > 0.) { + if (doscale1) { + for (; nl <= n2; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = s * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (med - Mems[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s1 = s * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (Mems[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + s1 = s * sqrt (max (one, med)) + for (; nl <= n2; nl = nl + 1) { + r = (med - Mems[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mems[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mems[d[n3-1]+k] + high = Mems[d[n3]+k] + med = (low + high) / 2. + } else + med = Mems[d[n3]+k] + } else + med = blank + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mems[d[n3-1]+k] + high = Mems[d[n3]+k] + med = (low + high) / 2. + } else + med = Mems[d[n3]+k] + } else + med = blank + } + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mems[d[l]+k] = Mems[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_aavsigclipi (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, s1, r, one +data one /1.0/ +pointer sp, sums, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (sums, npts, TY_REAL) + call salloc (resid, nimages+1, TY_REAL) + + # Since the unweighted average is computed here possibly skip combining + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Compute the unweighted average with the high and low rejected and + # the poisson scaled average sigma. There must be at least three + # pixels at each point to define the average and contributions to + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + nin = n[1] + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 < 3) + next + + # Unweighted average with the high and low rejected + low = Memi[d[1]+k] + high = Memi[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memi[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memi[dp1] + l = Memi[mp1] + s1 = max (one, (a + zeros[l]) / scales[l]) + s = s + (d1 - a) ** 2 / s1 + } + } else { + s1 = max (one, a) + do j = 1, n1 + s = s + (Memi[d[j]+k] - a) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the average and sum for later. + average[i] = a + Memr[sums+k] = sum + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + + # Reject pixels and compute the final average (if needed). + # There must be at least three pixels at each point for rejection. + # Iteratively scale the mean sigma and reject pixels + # Compact the data and keep track of the image IDs if needed. + + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (2, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memi[d[1]+k] + do j = 2, n1 + sum = sum + Memi[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + a = average[i] + sum = Memr[sums+k] + + repeat { + n2 = n1 + if (s > 0.) { + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memi[dp1] + l = Memi[mp1] + s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + s1 = s * sqrt (max (one, a)) + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memi[dp1] + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_mavsigclipi (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +pointer sp, resid, mp1, mp2 +real med, low, high, r, s, s1, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute the poisson scaled average sigma about the median. + # There must be at least three pixels at each point to define + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + s = 0. + n2 = 0 + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 < 3) { + if (n1 == 0) + median[i] = blank + else if (n1 == 1) + median[i] = Memi[d[1]+k] + else { + low = Memi[d[1]+k] + high = Memi[d[2]+k] + median[i] = (low + high) / 2. + } + next + } + + # Median + n3 = 1 + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memi[d[n3-1]+k] + high = Memi[d[n3]+k] + med = (low + high) / 2. + } else + med = Memi[d[n3]+k] + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + l = Memi[m[j]+k] + s1 = max (one, (med + zeros[l]) / scales[l]) + s = s + (Memi[d[j]+k] - med) ** 2 / s1 + } + } else { + s1 = max (one, med) + do j = 1, n1 + s = s + (Memi[d[j]+k] - med) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the median for later. + median[i] = med + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 < max (3, maxkeep+1)) + next + nl = 1 + nh = n1 + med = median[i] + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 >= max (MINCLIP, maxkeep+1) && s > 0.) { + if (doscale1) { + for (; nl <= n2; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = s * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (med - Memi[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s1 = s * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (Memi[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + s1 = s * sqrt (max (one, med)) + for (; nl <= n2; nl = nl + 1) { + r = (med - Memi[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memi[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memi[d[n3-1]+k] + high = Memi[d[n3]+k] + med = (low + high) / 2. + } else + med = Memi[d[n3]+k] + } else + med = blank + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memi[d[n3-1]+k] + high = Memi[d[n3]+k] + med = (low + high) / 2. + } else + med = Memi[d[n3]+k] + } else + med = blank + } + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memi[d[l]+k] = Memi[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memi[d[l]+k] = Memi[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_aavsigclipr (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, s1, r, one +data one /1.0/ +pointer sp, sums, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (sums, npts, TY_REAL) + call salloc (resid, nimages+1, TY_REAL) + + # Since the unweighted average is computed here possibly skip combining + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Compute the unweighted average with the high and low rejected and + # the poisson scaled average sigma. There must be at least three + # pixels at each point to define the average and contributions to + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + nin = n[1] + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 < 3) + next + + # Unweighted average with the high and low rejected + low = Memr[d[1]+k] + high = Memr[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memr[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memr[dp1] + l = Memi[mp1] + s1 = max (one, (a + zeros[l]) / scales[l]) + s = s + (d1 - a) ** 2 / s1 + } + } else { + s1 = max (one, a) + do j = 1, n1 + s = s + (Memr[d[j]+k] - a) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the average and sum for later. + average[i] = a + Memr[sums+k] = sum + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + + # Reject pixels and compute the final average (if needed). + # There must be at least three pixels at each point for rejection. + # Iteratively scale the mean sigma and reject pixels + # Compact the data and keep track of the image IDs if needed. + + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (2, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memr[d[1]+k] + do j = 2, n1 + sum = sum + Memr[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + a = average[i] + sum = Memr[sums+k] + + repeat { + n2 = n1 + if (s > 0.) { + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memr[dp1] + l = Memi[mp1] + s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + s1 = s * sqrt (max (one, a)) + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memr[dp1] + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_mavsigclipr (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +pointer sp, resid, mp1, mp2 +real med, low, high, r, s, s1, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute the poisson scaled average sigma about the median. + # There must be at least three pixels at each point to define + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + s = 0. + n2 = 0 + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 < 3) { + if (n1 == 0) + median[i] = blank + else if (n1 == 1) + median[i] = Memr[d[1]+k] + else { + low = Memr[d[1]+k] + high = Memr[d[2]+k] + median[i] = (low + high) / 2. + } + next + } + + # Median + n3 = 1 + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memr[d[n3-1]+k] + high = Memr[d[n3]+k] + med = (low + high) / 2. + } else + med = Memr[d[n3]+k] + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + l = Memi[m[j]+k] + s1 = max (one, (med + zeros[l]) / scales[l]) + s = s + (Memr[d[j]+k] - med) ** 2 / s1 + } + } else { + s1 = max (one, med) + do j = 1, n1 + s = s + (Memr[d[j]+k] - med) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the median for later. + median[i] = med + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 < max (3, maxkeep+1)) + next + nl = 1 + nh = n1 + med = median[i] + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 >= max (MINCLIP, maxkeep+1) && s > 0.) { + if (doscale1) { + for (; nl <= n2; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = s * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (med - Memr[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s1 = s * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (Memr[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + s1 = s * sqrt (max (one, med)) + for (; nl <= n2; nl = nl + 1) { + r = (med - Memr[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memr[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memr[d[n3-1]+k] + high = Memr[d[n3]+k] + med = (low + high) / 2. + } else + med = Memr[d[n3]+k] + } else + med = blank + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memr[d[n3-1]+k] + high = Memr[d[n3]+k] + med = (low + high) / 2. + } else + med = Memr[d[n3]+k] + } else + med = blank + } + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memr[d[l]+k] = Memr[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_aavsigclipd (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +double average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +double d1, low, high, sum, a, s, s1, r, one +data one /1.0D0/ +pointer sp, sums, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (sums, npts, TY_REAL) + call salloc (resid, nimages+1, TY_REAL) + + # Since the unweighted average is computed here possibly skip combining + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Compute the unweighted average with the high and low rejected and + # the poisson scaled average sigma. There must be at least three + # pixels at each point to define the average and contributions to + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + nin = n[1] + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 < 3) + next + + # Unweighted average with the high and low rejected + low = Memd[d[1]+k] + high = Memd[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memd[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memd[dp1] + l = Memi[mp1] + s1 = max (one, (a + zeros[l]) / scales[l]) + s = s + (d1 - a) ** 2 / s1 + } + } else { + s1 = max (one, a) + do j = 1, n1 + s = s + (Memd[d[j]+k] - a) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the average and sum for later. + average[i] = a + Memr[sums+k] = sum + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + + # Reject pixels and compute the final average (if needed). + # There must be at least three pixels at each point for rejection. + # Iteratively scale the mean sigma and reject pixels + # Compact the data and keep track of the image IDs if needed. + + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (2, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memd[d[1]+k] + do j = 2, n1 + sum = sum + Memd[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + a = average[i] + sum = Memr[sums+k] + + repeat { + n2 = n1 + if (s > 0.) { + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memd[dp1] + l = Memi[mp1] + s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + s1 = s * sqrt (max (one, a)) + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memd[dp1] + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_mavsigclipd (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +double median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +pointer sp, resid, mp1, mp2 +double med, low, high, r, s, s1, one +data one /1.0D0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute the poisson scaled average sigma about the median. + # There must be at least three pixels at each point to define + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + s = 0. + n2 = 0 + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 < 3) { + if (n1 == 0) + median[i] = blank + else if (n1 == 1) + median[i] = Memd[d[1]+k] + else { + low = Memd[d[1]+k] + high = Memd[d[2]+k] + median[i] = (low + high) / 2. + } + next + } + + # Median + n3 = 1 + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memd[d[n3-1]+k] + high = Memd[d[n3]+k] + med = (low + high) / 2. + } else + med = Memd[d[n3]+k] + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + l = Memi[m[j]+k] + s1 = max (one, (med + zeros[l]) / scales[l]) + s = s + (Memd[d[j]+k] - med) ** 2 / s1 + } + } else { + s1 = max (one, med) + do j = 1, n1 + s = s + (Memd[d[j]+k] - med) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the median for later. + median[i] = med + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 < max (3, maxkeep+1)) + next + nl = 1 + nh = n1 + med = median[i] + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 >= max (MINCLIP, maxkeep+1) && s > 0.) { + if (doscale1) { + for (; nl <= n2; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = s * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (med - Memd[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s1 = s * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (Memd[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + s1 = s * sqrt (max (one, med)) + for (; nl <= n2; nl = nl + 1) { + r = (med - Memd[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memd[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memd[d[n3-1]+k] + high = Memd[d[n3]+k] + med = (low + high) / 2. + } else + med = Memd[d[n3]+k] + } else + med = blank + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memd[d[n3-1]+k] + high = Memd[d[n3]+k] + med = (low + high) / 2. + } else + med = Memd[d[n3]+k] + } else + med = blank + } + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memd[d[l]+k] = Memd[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memd[d[l]+k] = Memd[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lscombine/src/generic/icaverage.x b/noao/twodspec/longslit/lscombine/src/generic/icaverage.x new file mode 100644 index 00000000..fc9f16da --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icaverage.x @@ -0,0 +1,406 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averages (d, m, n, wts, npts, doblank, doaverage, average) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k +real sumwt, wt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts) { + do i = 1, npts { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Mems[d[1]+k] * wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Mems[d[j]+k] * wt + } + average[i] = sum + } + } else { + do i = 1, npts { + k = i - 1 + sum = Mems[d[1]+k] + do j = 2, n[i] + sum = sum + Mems[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts) { + do i = 1, npts { + if (n[i] > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Mems[d[1]+k] * wt + sumwt = wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Mems[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Mems[d[1]+k] + do j = 2, n[i] + sum = sum + Mems[d[j]+k] + average[i] = sum / n[i] + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + if (n[i] > 0) { + k = i - 1 + sum = Mems[d[1]+k] + do j = 2, n[i] + sum = sum + Mems[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averagei (d, m, n, wts, npts, doblank, doaverage, average) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k +real sumwt, wt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts) { + do i = 1, npts { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memi[d[1]+k] * wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Memi[d[j]+k] * wt + } + average[i] = sum + } + } else { + do i = 1, npts { + k = i - 1 + sum = Memi[d[1]+k] + do j = 2, n[i] + sum = sum + Memi[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts) { + do i = 1, npts { + if (n[i] > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memi[d[1]+k] * wt + sumwt = wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Memi[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Memi[d[1]+k] + do j = 2, n[i] + sum = sum + Memi[d[j]+k] + average[i] = sum / n[i] + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + if (n[i] > 0) { + k = i - 1 + sum = Memi[d[1]+k] + do j = 2, n[i] + sum = sum + Memi[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averager (d, m, n, wts, npts, doblank, doaverage, average) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k +real sumwt, wt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts) { + do i = 1, npts { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memr[d[1]+k] * wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Memr[d[j]+k] * wt + } + average[i] = sum + } + } else { + do i = 1, npts { + k = i - 1 + sum = Memr[d[1]+k] + do j = 2, n[i] + sum = sum + Memr[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts) { + do i = 1, npts { + if (n[i] > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memr[d[1]+k] * wt + sumwt = wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Memr[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Memr[d[1]+k] + do j = 2, n[i] + sum = sum + Memr[d[j]+k] + average[i] = sum / n[i] + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + if (n[i] > 0) { + k = i - 1 + sum = Memr[d[1]+k] + do j = 2, n[i] + sum = sum + Memr[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averaged (d, m, n, wts, npts, doblank, doaverage, average) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +double average[npts] # Average (returned) + +int i, j, k +real sumwt, wt +double sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts) { + do i = 1, npts { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memd[d[1]+k] * wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Memd[d[j]+k] * wt + } + average[i] = sum + } + } else { + do i = 1, npts { + k = i - 1 + sum = Memd[d[1]+k] + do j = 2, n[i] + sum = sum + Memd[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts) { + do i = 1, npts { + if (n[i] > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memd[d[1]+k] * wt + sumwt = wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Memd[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Memd[d[1]+k] + do j = 2, n[i] + sum = sum + Memd[d[j]+k] + average[i] = sum / n[i] + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + if (n[i] > 0) { + k = i - 1 + sum = Memd[d[1]+k] + do j = 2, n[i] + sum = sum + Memd[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + diff --git a/noao/twodspec/longslit/lscombine/src/generic/iccclip.x b/noao/twodspec/longslit/lscombine/src/generic/iccclip.x new file mode 100644 index 00000000..bf655477 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/iccclip.x @@ -0,0 +1,1790 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 2 # Mininum number of images for algorithm + + +# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average + +procedure ic_accdclips (d, m, n, scales, zeros, nm, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model parameters +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, zero +data zero /0.0/ +pointer sp, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are no pixels go on to the combining. Since the unweighted + # average is computed here possibly skip the combining later. + + # There must be at least max (1, nkeep) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } else if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # There must be at least two pixels for rejection. The initial + # average is the low/high rejected average except in the case of + # just two pixels. The rejections are iterated and the average + # is recomputed. Corrections for scaling may be performed. + # Depending on other flags the image IDs may also need to be adjusted. + + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (MINCLIP-1, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mems[d[1]+k] + do j = 2, n1 + sum = sum + Mems[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + repeat { + if (n1 == 2) { + sum = Mems[d[1]+k] + sum = sum + Mems[d[2]+k] + a = sum / 2 + } else { + low = Mems[d[1]+k] + high = Mems[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mems[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + } + n2 = n1 + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + l = Memi[mp1] + s = scales[l] + d1 = max (zero, s * (a + zeros[l])) + s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s + + d1 = Mems[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + if (!keepids) { + s = max (zero, a) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (j=1; j<=n1; j=j+1) { + if (keepids) { + l = Memi[m[j]+k] + s = max (zero, a) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + dp1 = d[j] + k + d1 = Mems[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + } + + n[i] = n1 + if (!docombine) + if (n1 > 0) + average[i] = sum / n1 + else + average[i] = blank + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median + +procedure ic_mccdclips (d, m, n, scales, zeros, nm, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, mp1, mp2 +real med, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # There must be at least max (MINCLIP, nkeep+1) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) { + med = Mems[d[n3-1]+k] + med = (med + Mems[d[n3]+k]) / 2. + } else + med = Mems[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + for (; nl <= n2; nl = nl + 1) { + l = Memi[m[nl]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (med - Mems[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (Mems[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + if (!keepids) { + s = max (zero, med) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (; nl <= n2; nl = nl + 1) { + if (keepids) { + l = Memi[m[nl]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (med - Mems[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + if (keepids) { + l = Memi[m[nh]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (Mems[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mems[d[l]+k] = Mems[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average + +procedure ic_accdclipi (d, m, n, scales, zeros, nm, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model parameters +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, zero +data zero /0.0/ +pointer sp, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are no pixels go on to the combining. Since the unweighted + # average is computed here possibly skip the combining later. + + # There must be at least max (1, nkeep) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } else if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # There must be at least two pixels for rejection. The initial + # average is the low/high rejected average except in the case of + # just two pixels. The rejections are iterated and the average + # is recomputed. Corrections for scaling may be performed. + # Depending on other flags the image IDs may also need to be adjusted. + + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (MINCLIP-1, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memi[d[1]+k] + do j = 2, n1 + sum = sum + Memi[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + repeat { + if (n1 == 2) { + sum = Memi[d[1]+k] + sum = sum + Memi[d[2]+k] + a = sum / 2 + } else { + low = Memi[d[1]+k] + high = Memi[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memi[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + } + n2 = n1 + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + l = Memi[mp1] + s = scales[l] + d1 = max (zero, s * (a + zeros[l])) + s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s + + d1 = Memi[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + if (!keepids) { + s = max (zero, a) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (j=1; j<=n1; j=j+1) { + if (keepids) { + l = Memi[m[j]+k] + s = max (zero, a) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + dp1 = d[j] + k + d1 = Memi[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + } + + n[i] = n1 + if (!docombine) + if (n1 > 0) + average[i] = sum / n1 + else + average[i] = blank + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median + +procedure ic_mccdclipi (d, m, n, scales, zeros, nm, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, mp1, mp2 +real med, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # There must be at least max (MINCLIP, nkeep+1) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) { + med = Memi[d[n3-1]+k] + med = (med + Memi[d[n3]+k]) / 2. + } else + med = Memi[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + for (; nl <= n2; nl = nl + 1) { + l = Memi[m[nl]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (med - Memi[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (Memi[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + if (!keepids) { + s = max (zero, med) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (; nl <= n2; nl = nl + 1) { + if (keepids) { + l = Memi[m[nl]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (med - Memi[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + if (keepids) { + l = Memi[m[nh]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (Memi[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memi[d[l]+k] = Memi[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memi[d[l]+k] = Memi[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average + +procedure ic_accdclipr (d, m, n, scales, zeros, nm, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model parameters +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, zero +data zero /0.0/ +pointer sp, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are no pixels go on to the combining. Since the unweighted + # average is computed here possibly skip the combining later. + + # There must be at least max (1, nkeep) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } else if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # There must be at least two pixels for rejection. The initial + # average is the low/high rejected average except in the case of + # just two pixels. The rejections are iterated and the average + # is recomputed. Corrections for scaling may be performed. + # Depending on other flags the image IDs may also need to be adjusted. + + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (MINCLIP-1, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memr[d[1]+k] + do j = 2, n1 + sum = sum + Memr[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + repeat { + if (n1 == 2) { + sum = Memr[d[1]+k] + sum = sum + Memr[d[2]+k] + a = sum / 2 + } else { + low = Memr[d[1]+k] + high = Memr[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memr[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + } + n2 = n1 + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + l = Memi[mp1] + s = scales[l] + d1 = max (zero, s * (a + zeros[l])) + s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s + + d1 = Memr[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + if (!keepids) { + s = max (zero, a) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (j=1; j<=n1; j=j+1) { + if (keepids) { + l = Memi[m[j]+k] + s = max (zero, a) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + dp1 = d[j] + k + d1 = Memr[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + } + + n[i] = n1 + if (!docombine) + if (n1 > 0) + average[i] = sum / n1 + else + average[i] = blank + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median + +procedure ic_mccdclipr (d, m, n, scales, zeros, nm, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, mp1, mp2 +real med, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # There must be at least max (MINCLIP, nkeep+1) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) { + med = Memr[d[n3-1]+k] + med = (med + Memr[d[n3]+k]) / 2. + } else + med = Memr[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + for (; nl <= n2; nl = nl + 1) { + l = Memi[m[nl]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (med - Memr[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (Memr[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + if (!keepids) { + s = max (zero, med) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (; nl <= n2; nl = nl + 1) { + if (keepids) { + l = Memi[m[nl]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (med - Memr[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + if (keepids) { + l = Memi[m[nh]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (Memr[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memr[d[l]+k] = Memr[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average + +procedure ic_accdclipd (d, m, n, scales, zeros, nm, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model parameters +int nimages # Number of images +int npts # Number of output points per line +double average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +double d1, low, high, sum, a, s, r, zero +data zero /0.0D0/ +pointer sp, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are no pixels go on to the combining. Since the unweighted + # average is computed here possibly skip the combining later. + + # There must be at least max (1, nkeep) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } else if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # There must be at least two pixels for rejection. The initial + # average is the low/high rejected average except in the case of + # just two pixels. The rejections are iterated and the average + # is recomputed. Corrections for scaling may be performed. + # Depending on other flags the image IDs may also need to be adjusted. + + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (MINCLIP-1, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memd[d[1]+k] + do j = 2, n1 + sum = sum + Memd[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + repeat { + if (n1 == 2) { + sum = Memd[d[1]+k] + sum = sum + Memd[d[2]+k] + a = sum / 2 + } else { + low = Memd[d[1]+k] + high = Memd[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memd[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + } + n2 = n1 + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + l = Memi[mp1] + s = scales[l] + d1 = max (zero, s * (a + zeros[l])) + s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s + + d1 = Memd[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + if (!keepids) { + s = max (zero, a) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (j=1; j<=n1; j=j+1) { + if (keepids) { + l = Memi[m[j]+k] + s = max (zero, a) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + dp1 = d[j] + k + d1 = Memd[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + } + + n[i] = n1 + if (!docombine) + if (n1 > 0) + average[i] = sum / n1 + else + average[i] = blank + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median + +procedure ic_mccdclipd (d, m, n, scales, zeros, nm, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model +int nimages # Number of images +int npts # Number of output points per line +double median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, mp1, mp2 +double med, zero +data zero /0.0D0/ + +include "../icombine.com" + +begin + # There must be at least max (MINCLIP, nkeep+1) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) { + med = Memd[d[n3-1]+k] + med = (med + Memd[d[n3]+k]) / 2. + } else + med = Memd[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + for (; nl <= n2; nl = nl + 1) { + l = Memi[m[nl]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (med - Memd[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (Memd[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + if (!keepids) { + s = max (zero, med) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (; nl <= n2; nl = nl + 1) { + if (keepids) { + l = Memi[m[nl]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (med - Memd[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + if (keepids) { + l = Memi[m[nh]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (Memd[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memd[d[l]+k] = Memd[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memd[d[l]+k] = Memd[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lscombine/src/generic/icgdata.x b/noao/twodspec/longslit/lscombine/src/generic/icgdata.x new file mode 100644 index 00000000..5cefcf5a --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icgdata.x @@ -0,0 +1,1207 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include "../icombine.h" + + +# IC_GDATA -- Get line of image and mask data and apply threshold and scaling. +# Entirely empty lines are excluded. The data are compacted within the +# input data buffers. If it is required, the connection to the original +# image index is kept in the returned m data pointers. + +procedure ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets, scales, + zeros, nimages, npts, v1, v2) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +pointer dbuf[nimages] # Data buffers +pointer d[nimages] # Data pointers +pointer id[nimages] # ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Empty mask flags +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +int nimages # Number of input images +int npts # NUmber of output points per line +long v1[ARB], v2[ARB] # Line vectors + +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, xt_imgnls() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnls + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (dbuf[i] == NULL) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = xt_imgnls (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnls (in[i], i, buf, v2, v1[2]) + call amovs (Mems[buf+k-1], Mems[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Mems[dp] + if (a < lthresh || a > hthresh) { + Memi[m[i]+j-1] = 1 + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 1 + } + + # Check for completely empty lines + if (lflag[i] == D_MIX) { + lflag[i] = D_NONE + mp = m[i] + do j = 1, npts { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + a = Mems[dp] + if (a < lthresh || a > hthresh) { + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } + } + + # Apply scaling (avoiding masked pixels which might overflow?) + if (doscale) { + if (dflag == D_ALL) { + do i = 1, nimages { + dp = d[i] + a = scales[i] + b = -zeros[i] + do j = 1, npts { + Mems[dp] = Mems[dp] / a + b + dp = dp + 1 + } + } + } else if (dflag == D_MIX) { + do i = 1, nimages { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Mems[dp] = Mems[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) + Mems[dp] = Mems[dp] / a + b + dp = dp + 1 + mp = mp + 1 + } + } + } + } + } + + # Sort pointers to exclude unused images. + # Use the lflag array to keep track of the image index. + + if (dflag == D_ALL) + nused = nimages + else { + nused = 0 + do i = 1, nimages + if (lflag[i] != D_NONE) { + nused = nused + 1 + d[nused] = d[i] + m[nused] = m[i] + lflag[nused] = i + } + if (nused == 0) + dflag = D_NONE + } + + # Compact data to remove bad pixels + # Keep track of the image indices if needed + # If growing mark the end of the included image indices with zero + + if (dflag == D_ALL) { + call amovki (nused, n, npts) + if (keepids) + do i = 1, nimages + call amovki (i, Memi[id[i]], npts) + } else if (dflag == D_NONE) + call aclri (n, npts) + else { + call aclri (n, npts) + if (keepids) { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + Mems[d[k]+j-1] = Mems[dp] + Memi[id[k]+j-1] = l + } else + Memi[ip] = l + } + dp = dp + 1 + ip = ip + 1 + mp = mp + 1 + } + } + if (grow >= 1.) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) + Mems[d[k]+j-1] = Mems[dp] + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nimages, TY_SHORT) + if (keepids) { + call malloc (ip, nimages, TY_INT) + call ic_2sorts (d, Mems[dp], id, Memi[ip], n, npts) + call mfree (ip, TY_INT) + } else + call ic_sorts (d, Mems[dp], n, npts) + call mfree (dp, TY_SHORT) + } +end + +# IC_GDATA -- Get line of image and mask data and apply threshold and scaling. +# Entirely empty lines are excluded. The data are compacted within the +# input data buffers. If it is required, the connection to the original +# image index is kept in the returned m data pointers. + +procedure ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets, scales, + zeros, nimages, npts, v1, v2) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +pointer dbuf[nimages] # Data buffers +pointer d[nimages] # Data pointers +pointer id[nimages] # ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Empty mask flags +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +int nimages # Number of input images +int npts # NUmber of output points per line +long v1[ARB], v2[ARB] # Line vectors + +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, xt_imgnli() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnli + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (dbuf[i] == NULL) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = xt_imgnli (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnli (in[i], i, buf, v2, v1[2]) + call amovi (Memi[buf+k-1], Memi[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Memi[dp] + if (a < lthresh || a > hthresh) { + Memi[m[i]+j-1] = 1 + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 1 + } + + # Check for completely empty lines + if (lflag[i] == D_MIX) { + lflag[i] = D_NONE + mp = m[i] + do j = 1, npts { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + a = Memi[dp] + if (a < lthresh || a > hthresh) { + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } + } + + # Apply scaling (avoiding masked pixels which might overflow?) + if (doscale) { + if (dflag == D_ALL) { + do i = 1, nimages { + dp = d[i] + a = scales[i] + b = -zeros[i] + do j = 1, npts { + Memi[dp] = Memi[dp] / a + b + dp = dp + 1 + } + } + } else if (dflag == D_MIX) { + do i = 1, nimages { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Memi[dp] = Memi[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) + Memi[dp] = Memi[dp] / a + b + dp = dp + 1 + mp = mp + 1 + } + } + } + } + } + + # Sort pointers to exclude unused images. + # Use the lflag array to keep track of the image index. + + if (dflag == D_ALL) + nused = nimages + else { + nused = 0 + do i = 1, nimages + if (lflag[i] != D_NONE) { + nused = nused + 1 + d[nused] = d[i] + m[nused] = m[i] + lflag[nused] = i + } + if (nused == 0) + dflag = D_NONE + } + + # Compact data to remove bad pixels + # Keep track of the image indices if needed + # If growing mark the end of the included image indices with zero + + if (dflag == D_ALL) { + call amovki (nused, n, npts) + if (keepids) + do i = 1, nimages + call amovki (i, Memi[id[i]], npts) + } else if (dflag == D_NONE) + call aclri (n, npts) + else { + call aclri (n, npts) + if (keepids) { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + Memi[d[k]+j-1] = Memi[dp] + Memi[id[k]+j-1] = l + } else + Memi[ip] = l + } + dp = dp + 1 + ip = ip + 1 + mp = mp + 1 + } + } + if (grow >= 1.) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) + Memi[d[k]+j-1] = Memi[dp] + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nimages, TY_INT) + if (keepids) { + call malloc (ip, nimages, TY_INT) + call ic_2sorti (d, Memi[dp], id, Memi[ip], n, npts) + call mfree (ip, TY_INT) + } else + call ic_sorti (d, Memi[dp], n, npts) + call mfree (dp, TY_INT) + } +end + +# IC_GDATA -- Get line of image and mask data and apply threshold and scaling. +# Entirely empty lines are excluded. The data are compacted within the +# input data buffers. If it is required, the connection to the original +# image index is kept in the returned m data pointers. + +procedure ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets, scales, + zeros, nimages, npts, v1, v2) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +pointer dbuf[nimages] # Data buffers +pointer d[nimages] # Data pointers +pointer id[nimages] # ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Empty mask flags +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +int nimages # Number of input images +int npts # NUmber of output points per line +long v1[ARB], v2[ARB] # Line vectors + +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, xt_imgnlr() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnlr + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (dbuf[i] == NULL) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = xt_imgnlr (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnlr (in[i], i, buf, v2, v1[2]) + call amovr (Memr[buf+k-1], Memr[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Memr[dp] + if (a < lthresh || a > hthresh) { + Memi[m[i]+j-1] = 1 + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 1 + } + + # Check for completely empty lines + if (lflag[i] == D_MIX) { + lflag[i] = D_NONE + mp = m[i] + do j = 1, npts { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + a = Memr[dp] + if (a < lthresh || a > hthresh) { + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } + } + + # Apply scaling (avoiding masked pixels which might overflow?) + if (doscale) { + if (dflag == D_ALL) { + do i = 1, nimages { + dp = d[i] + a = scales[i] + b = -zeros[i] + do j = 1, npts { + Memr[dp] = Memr[dp] / a + b + dp = dp + 1 + } + } + } else if (dflag == D_MIX) { + do i = 1, nimages { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Memr[dp] = Memr[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) + Memr[dp] = Memr[dp] / a + b + dp = dp + 1 + mp = mp + 1 + } + } + } + } + } + + # Sort pointers to exclude unused images. + # Use the lflag array to keep track of the image index. + + if (dflag == D_ALL) + nused = nimages + else { + nused = 0 + do i = 1, nimages + if (lflag[i] != D_NONE) { + nused = nused + 1 + d[nused] = d[i] + m[nused] = m[i] + lflag[nused] = i + } + if (nused == 0) + dflag = D_NONE + } + + # Compact data to remove bad pixels + # Keep track of the image indices if needed + # If growing mark the end of the included image indices with zero + + if (dflag == D_ALL) { + call amovki (nused, n, npts) + if (keepids) + do i = 1, nimages + call amovki (i, Memi[id[i]], npts) + } else if (dflag == D_NONE) + call aclri (n, npts) + else { + call aclri (n, npts) + if (keepids) { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + Memr[d[k]+j-1] = Memr[dp] + Memi[id[k]+j-1] = l + } else + Memi[ip] = l + } + dp = dp + 1 + ip = ip + 1 + mp = mp + 1 + } + } + if (grow >= 1.) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) + Memr[d[k]+j-1] = Memr[dp] + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nimages, TY_REAL) + if (keepids) { + call malloc (ip, nimages, TY_INT) + call ic_2sortr (d, Memr[dp], id, Memi[ip], n, npts) + call mfree (ip, TY_INT) + } else + call ic_sortr (d, Memr[dp], n, npts) + call mfree (dp, TY_REAL) + } +end + +# IC_GDATA -- Get line of image and mask data and apply threshold and scaling. +# Entirely empty lines are excluded. The data are compacted within the +# input data buffers. If it is required, the connection to the original +# image index is kept in the returned m data pointers. + +procedure ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets, scales, + zeros, nimages, npts, v1, v2) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +pointer dbuf[nimages] # Data buffers +pointer d[nimages] # Data pointers +pointer id[nimages] # ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Empty mask flags +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +int nimages # Number of input images +int npts # NUmber of output points per line +long v1[ARB], v2[ARB] # Line vectors + +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, xt_imgnld() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnld + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (dbuf[i] == NULL) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = xt_imgnld (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnld (in[i], i, buf, v2, v1[2]) + call amovd (Memd[buf+k-1], Memd[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Memd[dp] + if (a < lthresh || a > hthresh) { + Memi[m[i]+j-1] = 1 + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 1 + } + + # Check for completely empty lines + if (lflag[i] == D_MIX) { + lflag[i] = D_NONE + mp = m[i] + do j = 1, npts { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + a = Memd[dp] + if (a < lthresh || a > hthresh) { + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } + } + + # Apply scaling (avoiding masked pixels which might overflow?) + if (doscale) { + if (dflag == D_ALL) { + do i = 1, nimages { + dp = d[i] + a = scales[i] + b = -zeros[i] + do j = 1, npts { + Memd[dp] = Memd[dp] / a + b + dp = dp + 1 + } + } + } else if (dflag == D_MIX) { + do i = 1, nimages { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Memd[dp] = Memd[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) + Memd[dp] = Memd[dp] / a + b + dp = dp + 1 + mp = mp + 1 + } + } + } + } + } + + # Sort pointers to exclude unused images. + # Use the lflag array to keep track of the image index. + + if (dflag == D_ALL) + nused = nimages + else { + nused = 0 + do i = 1, nimages + if (lflag[i] != D_NONE) { + nused = nused + 1 + d[nused] = d[i] + m[nused] = m[i] + lflag[nused] = i + } + if (nused == 0) + dflag = D_NONE + } + + # Compact data to remove bad pixels + # Keep track of the image indices if needed + # If growing mark the end of the included image indices with zero + + if (dflag == D_ALL) { + call amovki (nused, n, npts) + if (keepids) + do i = 1, nimages + call amovki (i, Memi[id[i]], npts) + } else if (dflag == D_NONE) + call aclri (n, npts) + else { + call aclri (n, npts) + if (keepids) { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + Memd[d[k]+j-1] = Memd[dp] + Memi[id[k]+j-1] = l + } else + Memi[ip] = l + } + dp = dp + 1 + ip = ip + 1 + mp = mp + 1 + } + } + if (grow >= 1.) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) + Memd[d[k]+j-1] = Memd[dp] + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nimages, TY_DOUBLE) + if (keepids) { + call malloc (ip, nimages, TY_INT) + call ic_2sortd (d, Memd[dp], id, Memi[ip], n, npts) + call mfree (ip, TY_INT) + } else + call ic_sortd (d, Memd[dp], n, npts) + call mfree (dp, TY_DOUBLE) + } +end + diff --git a/noao/twodspec/longslit/lscombine/src/generic/icgrow.x b/noao/twodspec/longslit/lscombine/src/generic/icgrow.x new file mode 100644 index 00000000..1ccb7885 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icgrow.x @@ -0,0 +1,263 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <pmset.h> +include "../icombine.h" + +# IC_GROW -- Mark neigbors of rejected pixels. +# The rejected pixels (original plus grown) are saved in pixel masks. + +procedure ic_grow (out, v, m, n, buf, nimages, npts, pms) + +pointer out # Output image pointer +long v[ARB] # Output vector +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[npts,nimages] # Working buffer +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k, l, line, nl, rop, igrow, nset, ncompress, or() +real grow2, i2 +pointer mp, pm, pm_newmask() +errchk pm_newmask() + +include "../icombine.com" + +begin + if (dflag == D_NONE || grow == 0.) + return + + line = v[2] + nl = IM_LEN(out,2) + rop = or (PIX_SRC, PIX_DST) + + igrow = grow + grow2 = grow**2 + do l = 0, igrow { + i2 = grow2 - l * l + call aclri (buf, npts*nimages) + nset = 0 + do j = 1, npts { + do k = n[j]+1, nimages { + mp = Memi[m[k]+j-1] + if (mp == 0) + next + do i = 0, igrow { + if (i**2 > i2) + next + if (j > i) + buf[j-i,mp] = 1 + if (j+i <= npts) + buf[j+i,mp] = 1 + nset = nset + 1 + } + } + } + if (nset == 0) + return + + if (pms == NULL) { + call malloc (pms, nimages, TY_POINTER) + do i = 1, nimages + Memi[pms+i-1] = pm_newmask (out, 1) + ncompress = 0 + } + do i = 1, nimages { + pm = Memi[pms+i-1] + v[2] = line - l + if (v[2] > 0) + call pmplpi (pm, v, buf[1,i], 1, npts, rop) + if (l > 0) { + v[2] = line + l + if (v[2] <= nl) + call pmplpi (pm, v, buf[1,i], 1, npts, rop) + } + } + } + v[2] = line + + if (ncompress > 10) { + do i = 1, nimages { + pm = Memi[pms+i-1] + call pm_compress (pm) + } + ncompress = 0 + } else + ncompress = ncompress + 1 +end + + + +# IC_GROW$T -- Reject pixels. + +procedure ic_grows (v, d, m, n, buf, nimages, npts, pms) + +long v[ARB] # Output vector +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[ARB] # Buffer of npts +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k +pointer pm +bool pl_linenotempty() + +include "../icombine.com" + +begin + do k = 1, nimages { + pm = Memi[pms+k-1] + if (!pl_linenotempty (pm, v)) + next + call pmglpi (pm, v, buf, 1, npts, PIX_SRC) + do i = 1, npts { + if (buf[i] == 0) + next + for (j = 1; j <= n[i]; j = j + 1) { + if (Memi[m[j]+i-1] == k) { + if (j < n[i]) { + Mems[d[j]+i-1] = Mems[d[n[i]]+i-1] + Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] + } + n[i] = n[i] - 1 + dflag = D_MIX + break + } + } + } + } +end + +# IC_GROW$T -- Reject pixels. + +procedure ic_growi (v, d, m, n, buf, nimages, npts, pms) + +long v[ARB] # Output vector +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[ARB] # Buffer of npts +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k +pointer pm +bool pl_linenotempty() + +include "../icombine.com" + +begin + do k = 1, nimages { + pm = Memi[pms+k-1] + if (!pl_linenotempty (pm, v)) + next + call pmglpi (pm, v, buf, 1, npts, PIX_SRC) + do i = 1, npts { + if (buf[i] == 0) + next + for (j = 1; j <= n[i]; j = j + 1) { + if (Memi[m[j]+i-1] == k) { + if (j < n[i]) { + Memi[d[j]+i-1] = Memi[d[n[i]]+i-1] + Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] + } + n[i] = n[i] - 1 + dflag = D_MIX + break + } + } + } + } +end + +# IC_GROW$T -- Reject pixels. + +procedure ic_growr (v, d, m, n, buf, nimages, npts, pms) + +long v[ARB] # Output vector +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[ARB] # Buffer of npts +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k +pointer pm +bool pl_linenotempty() + +include "../icombine.com" + +begin + do k = 1, nimages { + pm = Memi[pms+k-1] + if (!pl_linenotempty (pm, v)) + next + call pmglpi (pm, v, buf, 1, npts, PIX_SRC) + do i = 1, npts { + if (buf[i] == 0) + next + for (j = 1; j <= n[i]; j = j + 1) { + if (Memi[m[j]+i-1] == k) { + if (j < n[i]) { + Memr[d[j]+i-1] = Memr[d[n[i]]+i-1] + Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] + } + n[i] = n[i] - 1 + dflag = D_MIX + break + } + } + } + } +end + +# IC_GROW$T -- Reject pixels. + +procedure ic_growd (v, d, m, n, buf, nimages, npts, pms) + +long v[ARB] # Output vector +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[ARB] # Buffer of npts +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k +pointer pm +bool pl_linenotempty() + +include "../icombine.com" + +begin + do k = 1, nimages { + pm = Memi[pms+k-1] + if (!pl_linenotempty (pm, v)) + next + call pmglpi (pm, v, buf, 1, npts, PIX_SRC) + do i = 1, npts { + if (buf[i] == 0) + next + for (j = 1; j <= n[i]; j = j + 1) { + if (Memi[m[j]+i-1] == k) { + if (j < n[i]) { + Memd[d[j]+i-1] = Memd[d[n[i]]+i-1] + Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] + } + n[i] = n[i] - 1 + dflag = D_MIX + break + } + } + } + } +end diff --git a/noao/twodspec/longslit/lscombine/src/generic/icmedian.x b/noao/twodspec/longslit/lscombine/src/generic/icmedian.x new file mode 100644 index 00000000..1a2ed72d --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icmedian.x @@ -0,0 +1,692 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + + +# IC_MEDIAN -- Median of lines + +procedure ic_medians (d, n, npts, doblank, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +int doblank # Set blank values? +real median[npts] # Median + +int i, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +real val1, val2, val3 +short temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + even = (mod (n1, 2) == 0) + j1 = n1 / 2 + 1 + j2 = n1 / 2 + do i = 1, npts { + k = i - 1 + if (even) { + val1 = Mems[d[j1]+k] + val2 = Mems[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Mems[d[j1]+k] + } + } else { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod (n1, 2) == 0) { + j2 = n1 / 2 + val1 = Mems[d[j1]+k] + val2 = Mems[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Mems[d[j1]+k] + } else if (doblank == YES) + median[i] = blank + } + } + return + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = n[i] + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mems[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Mems[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Mems[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mems[d[lo1]+k] + Mems[d[lo1]+k] = Mems[d[up1]+k] + Mems[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Mems[d[j]+k] + + if (mod (n1,2) == 0) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mems[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Mems[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Mems[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mems[d[lo1]+k] + Mems[d[lo1]+k] = Mems[d[up1]+k] + Mems[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Mems[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else if (n1 == 3) { + val1 = Mems[d[1]+k] + val2 = Mems[d[2]+k] + val3 = Mems[d[3]+k] + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = val2 + else if (val1 < val3) # acb + median[i] = val3 + else # cab + median[i] = val1 + } else { + if (val2 > val3) # cba + median[i] = val2 + else if (val1 > val3) # bca + median[i] = val3 + else # bac + median[i] = val1 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Mems[d[1]+k] + val2 = Mems[d[2]+k] + median[i] = (val1 + val2) / 2 + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Mems[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end + +# IC_MEDIAN -- Median of lines + +procedure ic_mediani (d, n, npts, doblank, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +int doblank # Set blank values? +real median[npts] # Median + +int i, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +real val1, val2, val3 +int temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + even = (mod (n1, 2) == 0) + j1 = n1 / 2 + 1 + j2 = n1 / 2 + do i = 1, npts { + k = i - 1 + if (even) { + val1 = Memi[d[j1]+k] + val2 = Memi[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memi[d[j1]+k] + } + } else { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod (n1, 2) == 0) { + j2 = n1 / 2 + val1 = Memi[d[j1]+k] + val2 = Memi[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memi[d[j1]+k] + } else if (doblank == YES) + median[i] = blank + } + } + return + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = n[i] + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memi[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memi[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memi[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memi[d[lo1]+k] + Memi[d[lo1]+k] = Memi[d[up1]+k] + Memi[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Memi[d[j]+k] + + if (mod (n1,2) == 0) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memi[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memi[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memi[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memi[d[lo1]+k] + Memi[d[lo1]+k] = Memi[d[up1]+k] + Memi[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Memi[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else if (n1 == 3) { + val1 = Memi[d[1]+k] + val2 = Memi[d[2]+k] + val3 = Memi[d[3]+k] + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = val2 + else if (val1 < val3) # acb + median[i] = val3 + else # cab + median[i] = val1 + } else { + if (val2 > val3) # cba + median[i] = val2 + else if (val1 > val3) # bca + median[i] = val3 + else # bac + median[i] = val1 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Memi[d[1]+k] + val2 = Memi[d[2]+k] + median[i] = (val1 + val2) / 2 + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Memi[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end + +# IC_MEDIAN -- Median of lines + +procedure ic_medianr (d, n, npts, doblank, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +int doblank # Set blank values? +real median[npts] # Median + +int i, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +real val1, val2, val3 +real temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + even = (mod (n1, 2) == 0) + j1 = n1 / 2 + 1 + j2 = n1 / 2 + do i = 1, npts { + k = i - 1 + if (even) { + val1 = Memr[d[j1]+k] + val2 = Memr[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memr[d[j1]+k] + } + } else { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod (n1, 2) == 0) { + j2 = n1 / 2 + val1 = Memr[d[j1]+k] + val2 = Memr[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memr[d[j1]+k] + } else if (doblank == YES) + median[i] = blank + } + } + return + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = n[i] + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memr[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memr[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memr[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memr[d[lo1]+k] + Memr[d[lo1]+k] = Memr[d[up1]+k] + Memr[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Memr[d[j]+k] + + if (mod (n1,2) == 0) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memr[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memr[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memr[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memr[d[lo1]+k] + Memr[d[lo1]+k] = Memr[d[up1]+k] + Memr[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Memr[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else if (n1 == 3) { + val1 = Memr[d[1]+k] + val2 = Memr[d[2]+k] + val3 = Memr[d[3]+k] + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = val2 + else if (val1 < val3) # acb + median[i] = val3 + else # cab + median[i] = val1 + } else { + if (val2 > val3) # cba + median[i] = val2 + else if (val1 > val3) # bca + median[i] = val3 + else # bac + median[i] = val1 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Memr[d[1]+k] + val2 = Memr[d[2]+k] + median[i] = (val1 + val2) / 2 + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Memr[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end + +# IC_MEDIAN -- Median of lines + +procedure ic_mediand (d, n, npts, doblank, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +int doblank # Set blank values? +double median[npts] # Median + +int i, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +double val1, val2, val3 +double temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + even = (mod (n1, 2) == 0) + j1 = n1 / 2 + 1 + j2 = n1 / 2 + do i = 1, npts { + k = i - 1 + if (even) { + val1 = Memd[d[j1]+k] + val2 = Memd[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memd[d[j1]+k] + } + } else { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod (n1, 2) == 0) { + j2 = n1 / 2 + val1 = Memd[d[j1]+k] + val2 = Memd[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memd[d[j1]+k] + } else if (doblank == YES) + median[i] = blank + } + } + return + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = n[i] + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memd[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memd[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memd[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memd[d[lo1]+k] + Memd[d[lo1]+k] = Memd[d[up1]+k] + Memd[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Memd[d[j]+k] + + if (mod (n1,2) == 0) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memd[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memd[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memd[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memd[d[lo1]+k] + Memd[d[lo1]+k] = Memd[d[up1]+k] + Memd[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Memd[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else if (n1 == 3) { + val1 = Memd[d[1]+k] + val2 = Memd[d[2]+k] + val3 = Memd[d[3]+k] + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = val2 + else if (val1 < val3) # acb + median[i] = val3 + else # cab + median[i] = val1 + } else { + if (val2 > val3) # cba + median[i] = val2 + else if (val1 > val3) # bca + median[i] = val3 + else # bac + median[i] = val1 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Memd[d[1]+k] + val2 = Memd[d[2]+k] + median[i] = (val1 + val2) / 2 + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Memd[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end diff --git a/noao/twodspec/longslit/lscombine/src/generic/icmm.x b/noao/twodspec/longslit/lscombine/src/generic/icmm.x new file mode 100644 index 00000000..5b2b13bf --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icmm.x @@ -0,0 +1,644 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + + +# IC_MM -- Reject a specified number of high and low pixels + +procedure ic_mms (d, m, n, npts) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line + +int n1, ncombine, npairs, nlow, nhigh, np +int i, i1, j, jmax, jmin +pointer k, kmax, kmin +short d1, d2, dmin, dmax + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + if (dflag == D_ALL) { + n1 = n[1] + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = n1 - nlow - nhigh + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + do i = 1, npts { + i1 = i - 1 + n1 = n[i] + if (dflag == D_MIX) { + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = max (ncombine, n1 - nlow - nhigh) + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + # Reject the npairs low and high points. + do np = 1, npairs { + k = d[1] + i1 + d1 = Mems[k] + dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k + do j = 2, n1 { + d2 = d1 + k = d[j] + i1 + d1 = Mems[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } else if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + j = n1 - 1 + if (keepids) { + if (jmax < j) { + if (jmin != j) { + Mems[kmax] = d2 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Mems[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Mems[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Mems[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } else { + if (jmax < j) { + if (jmin != j) + Mems[kmax] = d2 + else + Mems[kmax] = d1 + } + if (jmin < j) { + if (jmax != n1) + Mems[kmin] = d1 + else + Mems[kmin] = d2 + } + } + n1 = n1 - 2 + } + + # Reject the excess low points. + do np = 1, nlow { + k = d[1] + i1 + d1 = Mems[k] + dmin = d1; jmin = 1; kmin = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Mems[k] + if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + if (keepids) { + if (jmin < n1) { + Mems[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmin < n1) + Mems[kmin] = d1 + } + n1 = n1 - 1 + } + + # Reject the excess high points. + do np = 1, nhigh { + k = d[1] + i1 + d1 = Mems[k] + dmax = d1; jmax = 1; kmax = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Mems[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } + } + if (keepids) { + if (jmax < n1) { + Mems[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmax < n1) + Mems[kmax] = d1 + } + n1 = n1 - 1 + } + n[i] = n1 + } + + if (dflag == D_ALL && npairs + nlow + nhigh > 0) + dflag = D_MIX +end + +# IC_MM -- Reject a specified number of high and low pixels + +procedure ic_mmi (d, m, n, npts) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line + +int n1, ncombine, npairs, nlow, nhigh, np +int i, i1, j, jmax, jmin +pointer k, kmax, kmin +int d1, d2, dmin, dmax + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + if (dflag == D_ALL) { + n1 = n[1] + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = n1 - nlow - nhigh + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + do i = 1, npts { + i1 = i - 1 + n1 = n[i] + if (dflag == D_MIX) { + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = max (ncombine, n1 - nlow - nhigh) + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + # Reject the npairs low and high points. + do np = 1, npairs { + k = d[1] + i1 + d1 = Memi[k] + dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k + do j = 2, n1 { + d2 = d1 + k = d[j] + i1 + d1 = Memi[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } else if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + j = n1 - 1 + if (keepids) { + if (jmax < j) { + if (jmin != j) { + Memi[kmax] = d2 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Memi[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Memi[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Memi[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } else { + if (jmax < j) { + if (jmin != j) + Memi[kmax] = d2 + else + Memi[kmax] = d1 + } + if (jmin < j) { + if (jmax != n1) + Memi[kmin] = d1 + else + Memi[kmin] = d2 + } + } + n1 = n1 - 2 + } + + # Reject the excess low points. + do np = 1, nlow { + k = d[1] + i1 + d1 = Memi[k] + dmin = d1; jmin = 1; kmin = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memi[k] + if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + if (keepids) { + if (jmin < n1) { + Memi[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmin < n1) + Memi[kmin] = d1 + } + n1 = n1 - 1 + } + + # Reject the excess high points. + do np = 1, nhigh { + k = d[1] + i1 + d1 = Memi[k] + dmax = d1; jmax = 1; kmax = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memi[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } + } + if (keepids) { + if (jmax < n1) { + Memi[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmax < n1) + Memi[kmax] = d1 + } + n1 = n1 - 1 + } + n[i] = n1 + } + + if (dflag == D_ALL && npairs + nlow + nhigh > 0) + dflag = D_MIX +end + +# IC_MM -- Reject a specified number of high and low pixels + +procedure ic_mmr (d, m, n, npts) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line + +int n1, ncombine, npairs, nlow, nhigh, np +int i, i1, j, jmax, jmin +pointer k, kmax, kmin +real d1, d2, dmin, dmax + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + if (dflag == D_ALL) { + n1 = n[1] + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = n1 - nlow - nhigh + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + do i = 1, npts { + i1 = i - 1 + n1 = n[i] + if (dflag == D_MIX) { + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = max (ncombine, n1 - nlow - nhigh) + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + # Reject the npairs low and high points. + do np = 1, npairs { + k = d[1] + i1 + d1 = Memr[k] + dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k + do j = 2, n1 { + d2 = d1 + k = d[j] + i1 + d1 = Memr[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } else if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + j = n1 - 1 + if (keepids) { + if (jmax < j) { + if (jmin != j) { + Memr[kmax] = d2 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Memr[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Memr[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Memr[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } else { + if (jmax < j) { + if (jmin != j) + Memr[kmax] = d2 + else + Memr[kmax] = d1 + } + if (jmin < j) { + if (jmax != n1) + Memr[kmin] = d1 + else + Memr[kmin] = d2 + } + } + n1 = n1 - 2 + } + + # Reject the excess low points. + do np = 1, nlow { + k = d[1] + i1 + d1 = Memr[k] + dmin = d1; jmin = 1; kmin = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memr[k] + if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + if (keepids) { + if (jmin < n1) { + Memr[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmin < n1) + Memr[kmin] = d1 + } + n1 = n1 - 1 + } + + # Reject the excess high points. + do np = 1, nhigh { + k = d[1] + i1 + d1 = Memr[k] + dmax = d1; jmax = 1; kmax = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memr[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } + } + if (keepids) { + if (jmax < n1) { + Memr[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmax < n1) + Memr[kmax] = d1 + } + n1 = n1 - 1 + } + n[i] = n1 + } + + if (dflag == D_ALL && npairs + nlow + nhigh > 0) + dflag = D_MIX +end + +# IC_MM -- Reject a specified number of high and low pixels + +procedure ic_mmd (d, m, n, npts) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line + +int n1, ncombine, npairs, nlow, nhigh, np +int i, i1, j, jmax, jmin +pointer k, kmax, kmin +double d1, d2, dmin, dmax + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + if (dflag == D_ALL) { + n1 = n[1] + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = n1 - nlow - nhigh + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + do i = 1, npts { + i1 = i - 1 + n1 = n[i] + if (dflag == D_MIX) { + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = max (ncombine, n1 - nlow - nhigh) + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + # Reject the npairs low and high points. + do np = 1, npairs { + k = d[1] + i1 + d1 = Memd[k] + dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k + do j = 2, n1 { + d2 = d1 + k = d[j] + i1 + d1 = Memd[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } else if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + j = n1 - 1 + if (keepids) { + if (jmax < j) { + if (jmin != j) { + Memd[kmax] = d2 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Memd[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Memd[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Memd[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } else { + if (jmax < j) { + if (jmin != j) + Memd[kmax] = d2 + else + Memd[kmax] = d1 + } + if (jmin < j) { + if (jmax != n1) + Memd[kmin] = d1 + else + Memd[kmin] = d2 + } + } + n1 = n1 - 2 + } + + # Reject the excess low points. + do np = 1, nlow { + k = d[1] + i1 + d1 = Memd[k] + dmin = d1; jmin = 1; kmin = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memd[k] + if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + if (keepids) { + if (jmin < n1) { + Memd[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmin < n1) + Memd[kmin] = d1 + } + n1 = n1 - 1 + } + + # Reject the excess high points. + do np = 1, nhigh { + k = d[1] + i1 + d1 = Memd[k] + dmax = d1; jmax = 1; kmax = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memd[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } + } + if (keepids) { + if (jmax < n1) { + Memd[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmax < n1) + Memd[kmax] = d1 + } + n1 = n1 - 1 + } + n[i] = n1 + } + + if (dflag == D_ALL && npairs + nlow + nhigh > 0) + dflag = D_MIX +end diff --git a/noao/twodspec/longslit/lscombine/src/generic/icomb.x b/noao/twodspec/longslit/lscombine/src/generic/icomb.x new file mode 100644 index 00000000..96138646 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icomb.x @@ -0,0 +1,1917 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <pmset.h> +include <error.h> +include <syserr.h> +include <mach.h> +include "../icombine.h" + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include <imset.h> + + +# ICOMBINE -- Combine images +# +# The memory and open file descriptor limits are checked and an attempt +# to recover is made either by setting the image pixel files to be +# closed after I/O or by notifying the calling program that memory +# ran out and the IMIO buffer size should be reduced. After the checks +# a procedure for the selected combine option is called. +# Because there may be several failure modes when reaching the file +# limits we first assume an error is due to the file limit, except for +# out of memory, and close some pixel files. If the error then repeats +# on accessing the pixels the error is passed back. + + +procedure icombines (in, out, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnls() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnls, impl1i, ic_combines +pointer impl1r() +errchk impl1r + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + call salloc (dbuf, nimages, TY_POINTER) + call salloc (d, nimages, TY_POINTER) + call salloc (id, nimages, TY_POINTER) + call salloc (n, npts, TY_INT) + call salloc (m, nimages, TY_POINTER) + call salloc (lflag, nimages, TY_INT) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # If not aligned or growing create data buffers of output length + # otherwise use the IMIO buffers. + + if (!aligned || grow >= 1.) { + do i = 1, nimages + call salloc (Memi[dbuf+i-1], npts, TY_SHORT) + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) + call salloc (Memi[dbuf+i-1], npts, TY_SHORT) + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + } else { + # Reserve FD for string operations. + fd = stropen (str, 1, NEW_FILE) + + # Do I/O to the images. + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + buf = impl1r (out[1]) + call aclrr (Memr[buf], npts) + if (out[3] != NULL) { + buf = impl1r (out[3]) + call aclrr (Memr[buf], npts) + } + if (out[2] != NULL) { + buf = impl1i (out[2]) + call aclri (Memi[buf], npts) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnls (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + } + } + + call strclose (fd) + } + + call ic_combines (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], + Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) +end + + +# IC_COMBINE -- Combine images. + +procedure ic_combines (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, wts, nimages, npts) + +pointer in[nimages] # Input images +pointer out[ARB] # Output image +pointer dbuf[nimages] # Data buffers for nonaligned images +pointer d[nimages] # Data pointers +pointer id[nimages] # Image index ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Line flags +int offsets[nimages,ARB] # Input image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +real wts[nimages] # Combining weights +int nimages # Number of input images +int npts # Number of points per output line + +int i, ext, ctor(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nm, pms +pointer immap(), impnli() +pointer impnlr(), imgnlr() +errchk immap, ic_scale, imgetr, ic_grow, ic_grows, ic_rmasks, ic_gdatas + +include "../icombine.com" +data ext/0/ + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + call ic_scale (in, out, offsets, scales, zeros, wts, nimages) + + # Set combine parameters + switch (combine) { + case AVERAGE: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Set rejection algorithm specific parameters + switch (reject) { + case CCDCLIP, CRREJECT: + call salloc (nm, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nm+3*(i-1)+2] = r + } + } + if (!keepids) { + if (doscale1) + keepids = true + else { + do i = 2, nimages { + if (Memr[nm+3*(i-1)] != Memr[nm] || + Memr[nm+3*(i-1)+1] != Memr[nm+1] || + Memr[nm+3*(i-1)+2] != Memr[nm+2]) { + keepids = true + break + } + } + } + } + if (reject == CRREJECT) + lsigma = MAX_REAL + case MINMAX: + mclip = false + case PCLIP: + mclip = true + case AVSIGCLIP, SIGCLIP: + if (doscale1) + keepids = true + case NONE: + mclip = false + } + + if (out[4] != NULL) + keepids = true + + if (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + if (grow >= 1.) { + keepids = true + call salloc (work, npts * nimages, TY_INT) + } + pms = NULL + + if (keepids) { + do i = 1, nimages + call salloc (id[i], npts, TY_INT) + } + + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclips (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + else + call ic_accdclips (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + case MINMAX: + call ic_mms (d, id, n, npts) + case PCLIP: + call ic_pclips (d, id, n, nimages, npts, Memr[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclips (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + else + call ic_asigclips (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclips (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + else + call ic_aavsigclips (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averages (d, id, n, wts, npts, YES, YES, + Memr[outdata]) + case MEDIAN: + call ic_medians (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_averages (d, id, n, wts, npts, YES, NO, + Memr[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmas (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + if (pms != NULL) { + if (nkeep > 0) { + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call imunmap (out[1]) + iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { + switch (errcode()) { + case SYS_FXFOPNOEXTNV: + call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) + ext = ext + 1 + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext) + iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { + buf = NULL + ext = 0 + } + repeat { + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext+1) + iferr (outdata = immap (Memc[imname],READ_WRITE,0)) + break + if (buf != NULL) + call imunmap (buf) + buf = outdata + ext = ext + 1 + } + default: + call erract (EA_ERROR) + } + } + out[1] = buf + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_grows (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnlr (out[1], buf, Meml[v1]) == EOF) + ; + call amovr (Memr[buf], Memr[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_averages (d, id, n, wts, npts, NO, YES, + Memr[outdata]) + case MEDIAN: + call ic_medians (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_averages (d, id, n, wts, npts, NO, NO, + Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmas (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + do i = 1, nimages + call pm_close (Memi[pms+i-1]) + call mfree (pms, TY_POINTER) + } + + call sfree (sp) +end + +procedure icombinei (in, out, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnli() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnli, impl1i, ic_combinei +pointer impl1r() +errchk impl1r + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + call salloc (dbuf, nimages, TY_POINTER) + call salloc (d, nimages, TY_POINTER) + call salloc (id, nimages, TY_POINTER) + call salloc (n, npts, TY_INT) + call salloc (m, nimages, TY_POINTER) + call salloc (lflag, nimages, TY_INT) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # If not aligned or growing create data buffers of output length + # otherwise use the IMIO buffers. + + if (!aligned || grow >= 1.) { + do i = 1, nimages + call salloc (Memi[dbuf+i-1], npts, TY_INT) + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) + call salloc (Memi[dbuf+i-1], npts, TY_INT) + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + } else { + # Reserve FD for string operations. + fd = stropen (str, 1, NEW_FILE) + + # Do I/O to the images. + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + buf = impl1r (out[1]) + call aclrr (Memr[buf], npts) + if (out[3] != NULL) { + buf = impl1r (out[3]) + call aclrr (Memr[buf], npts) + } + if (out[2] != NULL) { + buf = impl1i (out[2]) + call aclri (Memi[buf], npts) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnli (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + } + } + + call strclose (fd) + } + + call ic_combinei (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], + Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) +end + + +# IC_COMBINE -- Combine images. + +procedure ic_combinei (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, wts, nimages, npts) + +pointer in[nimages] # Input images +pointer out[ARB] # Output image +pointer dbuf[nimages] # Data buffers for nonaligned images +pointer d[nimages] # Data pointers +pointer id[nimages] # Image index ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Line flags +int offsets[nimages,ARB] # Input image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +real wts[nimages] # Combining weights +int nimages # Number of input images +int npts # Number of points per output line + +int i, ext, ctor(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nm, pms +pointer immap(), impnli() +pointer impnlr(), imgnlr() +errchk immap, ic_scale, imgetr, ic_grow, ic_growi, ic_rmasks, ic_gdatai + +include "../icombine.com" +data ext/0/ + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + call ic_scale (in, out, offsets, scales, zeros, wts, nimages) + + # Set combine parameters + switch (combine) { + case AVERAGE: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Set rejection algorithm specific parameters + switch (reject) { + case CCDCLIP, CRREJECT: + call salloc (nm, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nm+3*(i-1)+2] = r + } + } + if (!keepids) { + if (doscale1) + keepids = true + else { + do i = 2, nimages { + if (Memr[nm+3*(i-1)] != Memr[nm] || + Memr[nm+3*(i-1)+1] != Memr[nm+1] || + Memr[nm+3*(i-1)+2] != Memr[nm+2]) { + keepids = true + break + } + } + } + } + if (reject == CRREJECT) + lsigma = MAX_REAL + case MINMAX: + mclip = false + case PCLIP: + mclip = true + case AVSIGCLIP, SIGCLIP: + if (doscale1) + keepids = true + case NONE: + mclip = false + } + + if (out[4] != NULL) + keepids = true + + if (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + if (grow >= 1.) { + keepids = true + call salloc (work, npts * nimages, TY_INT) + } + pms = NULL + + if (keepids) { + do i = 1, nimages + call salloc (id[i], npts, TY_INT) + } + + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclipi (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + else + call ic_accdclipi (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + case MINMAX: + call ic_mmi (d, id, n, npts) + case PCLIP: + call ic_pclipi (d, id, n, nimages, npts, Memr[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclipi (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + else + call ic_asigclipi (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclipi (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + else + call ic_aavsigclipi (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averagei (d, id, n, wts, npts, YES, YES, + Memr[outdata]) + case MEDIAN: + call ic_mediani (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_averagei (d, id, n, wts, npts, YES, NO, + Memr[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmai (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + if (pms != NULL) { + if (nkeep > 0) { + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call imunmap (out[1]) + iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { + switch (errcode()) { + case SYS_FXFOPNOEXTNV: + call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) + ext = ext + 1 + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext) + iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { + buf = NULL + ext = 0 + } + repeat { + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext+1) + iferr (outdata = immap (Memc[imname],READ_WRITE,0)) + break + if (buf != NULL) + call imunmap (buf) + buf = outdata + ext = ext + 1 + } + default: + call erract (EA_ERROR) + } + } + out[1] = buf + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_growi (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnlr (out[1], buf, Meml[v1]) == EOF) + ; + call amovr (Memr[buf], Memr[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_averagei (d, id, n, wts, npts, NO, YES, + Memr[outdata]) + case MEDIAN: + call ic_mediani (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_averagei (d, id, n, wts, npts, NO, NO, + Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmai (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + do i = 1, nimages + call pm_close (Memi[pms+i-1]) + call mfree (pms, TY_POINTER) + } + + call sfree (sp) +end + +procedure icombiner (in, out, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnlr() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnlr, impl1i, ic_combiner +pointer impl1r() +errchk impl1r + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + call salloc (dbuf, nimages, TY_POINTER) + call salloc (d, nimages, TY_POINTER) + call salloc (id, nimages, TY_POINTER) + call salloc (n, npts, TY_INT) + call salloc (m, nimages, TY_POINTER) + call salloc (lflag, nimages, TY_INT) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # If not aligned or growing create data buffers of output length + # otherwise use the IMIO buffers. + + if (!aligned || grow >= 1.) { + do i = 1, nimages + call salloc (Memi[dbuf+i-1], npts, TY_REAL) + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) + call salloc (Memi[dbuf+i-1], npts, TY_REAL) + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + } else { + # Reserve FD for string operations. + fd = stropen (str, 1, NEW_FILE) + + # Do I/O to the images. + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + buf = impl1r (out[1]) + call aclrr (Memr[buf], npts) + if (out[3] != NULL) { + buf = impl1r (out[3]) + call aclrr (Memr[buf], npts) + } + if (out[2] != NULL) { + buf = impl1i (out[2]) + call aclri (Memi[buf], npts) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnlr (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + } + } + + call strclose (fd) + } + + call ic_combiner (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], + Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) +end + + +# IC_COMBINE -- Combine images. + +procedure ic_combiner (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, wts, nimages, npts) + +pointer in[nimages] # Input images +pointer out[ARB] # Output image +pointer dbuf[nimages] # Data buffers for nonaligned images +pointer d[nimages] # Data pointers +pointer id[nimages] # Image index ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Line flags +int offsets[nimages,ARB] # Input image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +real wts[nimages] # Combining weights +int nimages # Number of input images +int npts # Number of points per output line + +int i, ext, ctor(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nm, pms +pointer immap(), impnli() +pointer impnlr(), imgnlr +errchk immap, ic_scale, imgetr, ic_grow, ic_growr, ic_rmasks, ic_gdatar + +include "../icombine.com" +data ext/0/ + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + call ic_scale (in, out, offsets, scales, zeros, wts, nimages) + + # Set combine parameters + switch (combine) { + case AVERAGE: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Set rejection algorithm specific parameters + switch (reject) { + case CCDCLIP, CRREJECT: + call salloc (nm, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nm+3*(i-1)+2] = r + } + } + if (!keepids) { + if (doscale1) + keepids = true + else { + do i = 2, nimages { + if (Memr[nm+3*(i-1)] != Memr[nm] || + Memr[nm+3*(i-1)+1] != Memr[nm+1] || + Memr[nm+3*(i-1)+2] != Memr[nm+2]) { + keepids = true + break + } + } + } + } + if (reject == CRREJECT) + lsigma = MAX_REAL + case MINMAX: + mclip = false + case PCLIP: + mclip = true + case AVSIGCLIP, SIGCLIP: + if (doscale1) + keepids = true + case NONE: + mclip = false + } + + if (out[4] != NULL) + keepids = true + + if (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + if (grow >= 1.) { + keepids = true + call salloc (work, npts * nimages, TY_INT) + } + pms = NULL + + if (keepids) { + do i = 1, nimages + call salloc (id[i], npts, TY_INT) + } + + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclipr (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + else + call ic_accdclipr (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + case MINMAX: + call ic_mmr (d, id, n, npts) + case PCLIP: + call ic_pclipr (d, id, n, nimages, npts, Memr[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclipr (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + else + call ic_asigclipr (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclipr (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + else + call ic_aavsigclipr (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averager (d, id, n, wts, npts, YES, YES, + Memr[outdata]) + case MEDIAN: + call ic_medianr (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_averager (d, id, n, wts, npts, YES, NO, + Memr[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmar (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + if (pms != NULL) { + if (nkeep > 0) { + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call imunmap (out[1]) + iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { + switch (errcode()) { + case SYS_FXFOPNOEXTNV: + call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) + ext = ext + 1 + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext) + iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { + buf = NULL + ext = 0 + } + repeat { + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext+1) + iferr (outdata = immap (Memc[imname],READ_WRITE,0)) + break + if (buf != NULL) + call imunmap (buf) + buf = outdata + ext = ext + 1 + } + default: + call erract (EA_ERROR) + } + } + out[1] = buf + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_growr (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnlr (out[1], buf, Meml[v1]) == EOF) + ; + call amovr (Memr[buf], Memr[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_averager (d, id, n, wts, npts, NO, YES, + Memr[outdata]) + case MEDIAN: + call ic_medianr (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_averager (d, id, n, wts, npts, NO, NO, + Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmar (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + do i = 1, nimages + call pm_close (Memi[pms+i-1]) + call mfree (pms, TY_POINTER) + } + + call sfree (sp) +end + +procedure icombined (in, out, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnld() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnld, impl1i, ic_combined +pointer impl1d() +errchk impl1d + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + call salloc (dbuf, nimages, TY_POINTER) + call salloc (d, nimages, TY_POINTER) + call salloc (id, nimages, TY_POINTER) + call salloc (n, npts, TY_INT) + call salloc (m, nimages, TY_POINTER) + call salloc (lflag, nimages, TY_INT) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # If not aligned or growing create data buffers of output length + # otherwise use the IMIO buffers. + + if (!aligned || grow >= 1.) { + do i = 1, nimages + call salloc (Memi[dbuf+i-1], npts, TY_DOUBLE) + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) + call salloc (Memi[dbuf+i-1], npts, TY_DOUBLE) + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + } else { + # Reserve FD for string operations. + fd = stropen (str, 1, NEW_FILE) + + # Do I/O to the images. + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + buf = impl1d (out[1]) + call aclrd (Memd[buf], npts) + if (out[3] != NULL) { + buf = impl1d (out[3]) + call aclrd (Memd[buf], npts) + } + if (out[2] != NULL) { + buf = impl1i (out[2]) + call aclri (Memi[buf], npts) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnld (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + } + } + + call strclose (fd) + } + + call ic_combined (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], + Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) +end + + +# IC_COMBINE -- Combine images. + +procedure ic_combined (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, wts, nimages, npts) + +pointer in[nimages] # Input images +pointer out[ARB] # Output image +pointer dbuf[nimages] # Data buffers for nonaligned images +pointer d[nimages] # Data pointers +pointer id[nimages] # Image index ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Line flags +int offsets[nimages,ARB] # Input image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +real wts[nimages] # Combining weights +int nimages # Number of input images +int npts # Number of points per output line + +int i, ext, ctor(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nm, pms +pointer immap(), impnli() +pointer impnld(), imgnld +errchk immap, ic_scale, imgetr, ic_grow, ic_growd, ic_rmasks, ic_gdatad + +include "../icombine.com" +data ext/0/ + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + call ic_scale (in, out, offsets, scales, zeros, wts, nimages) + + # Set combine parameters + switch (combine) { + case AVERAGE: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Set rejection algorithm specific parameters + switch (reject) { + case CCDCLIP, CRREJECT: + call salloc (nm, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nm+3*(i-1)+2] = r + } + } + if (!keepids) { + if (doscale1) + keepids = true + else { + do i = 2, nimages { + if (Memr[nm+3*(i-1)] != Memr[nm] || + Memr[nm+3*(i-1)+1] != Memr[nm+1] || + Memr[nm+3*(i-1)+2] != Memr[nm+2]) { + keepids = true + break + } + } + } + } + if (reject == CRREJECT) + lsigma = MAX_REAL + case MINMAX: + mclip = false + case PCLIP: + mclip = true + case AVSIGCLIP, SIGCLIP: + if (doscale1) + keepids = true + case NONE: + mclip = false + } + + if (out[4] != NULL) + keepids = true + + if (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + if (grow >= 1.) { + keepids = true + call salloc (work, npts * nimages, TY_INT) + } + pms = NULL + + if (keepids) { + do i = 1, nimages + call salloc (id[i], npts, TY_INT) + } + + while (impnld (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclipd (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memd[outdata]) + else + call ic_accdclipd (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memd[outdata]) + case MINMAX: + call ic_mmd (d, id, n, npts) + case PCLIP: + call ic_pclipd (d, id, n, nimages, npts, Memd[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclipd (d, id, n, scales, zeros, nimages, npts, + Memd[outdata]) + else + call ic_asigclipd (d, id, n, scales, zeros, nimages, npts, + Memd[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclipd (d, id, n, scales, zeros, nimages, + npts, Memd[outdata]) + else + call ic_aavsigclipd (d, id, n, scales, zeros, nimages, + npts, Memd[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averaged (d, id, n, wts, npts, YES, YES, + Memd[outdata]) + case MEDIAN: + call ic_mediand (d, n, npts, YES, Memd[outdata]) + case SUM: + call ic_averaged (d, id, n, wts, npts, YES, NO, + Memd[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnld (out[3], buf, Meml[v1]) + call ic_sigmad (d, id, n, wts, npts, Memd[outdata], + Memd[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + if (pms != NULL) { + if (nkeep > 0) { + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call imunmap (out[1]) + iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { + switch (errcode()) { + case SYS_FXFOPNOEXTNV: + call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) + ext = ext + 1 + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext) + iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { + buf = NULL + ext = 0 + } + repeat { + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext+1) + iferr (outdata = immap (Memc[imname],READ_WRITE,0)) + break + if (buf != NULL) + call imunmap (buf) + buf = outdata + ext = ext + 1 + } + default: + call erract (EA_ERROR) + } + } + out[1] = buf + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + while (impnld (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_growd (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnld (out[1], buf, Meml[v1]) == EOF) + ; + call amovd (Memd[buf], Memd[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_averaged (d, id, n, wts, npts, NO, YES, + Memd[outdata]) + case MEDIAN: + call ic_mediand (d, n, npts, NO, Memd[outdata]) + case SUM: + call ic_averaged (d, id, n, wts, npts, NO, NO, + Memd[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnld (out[3], buf, Meml[v1]) + call ic_sigmad (d, id, n, wts, npts, Memd[outdata], + Memd[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + do i = 1, nimages + call pm_close (Memi[pms+i-1]) + call mfree (pms, TY_POINTER) + } + + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lscombine/src/generic/icpclip.x b/noao/twodspec/longslit/lscombine/src/generic/icpclip.x new file mode 100644 index 00000000..237d9686 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icpclip.x @@ -0,0 +1,878 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Minimum number for clipping + + +# IC_PCLIP -- Percentile clip +# +# 1) Find the median +# 2) Find the pixel which is the specified order index away +# 3) Use the data value difference as a sigma and apply clipping +# 4) Since the median is known return it so it does not have to be recomputed + +procedure ic_pclips (d, m, n, nimages, npts, median) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of input images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep +bool even, fp_equalr() +real sigma, r, s, t +pointer sp, resid, mp1, mp2 +real med + +include "../icombine.com" + +begin + # There must be at least MINCLIP and more than nkeep pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Set sign of pclip parameter + if (pclip < 0) + t = -1. + else + t = 1. + + # If there are no rejected pixels compute certain parameters once. + if (dflag == D_ALL) { + n1 = n[1] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0.) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + nin = n1 + } + + # Now apply clipping. + do i = 1, npts { + # Compute median. + if (dflag == D_MIX) { + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 == 0) { + if (combine == MEDIAN) + median[i] = blank + next + } + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + } + + j = i - 1 + if (even) { + med = Mems[d[n2-1]+j] + med = (med + Mems[d[n2]+j]) / 2. + } else + med = Mems[d[n2]+j] + + if (n1 < max (MINCLIP, maxkeep+1)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Define sigma for clipping + sigma = t * (Mems[d[n3]+j] - med) + if (fp_equalr (sigma, 0.)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Reject pixels and save residuals. + # Check if any pixels are clipped. + # If so recompute the median and reset the number of good pixels. + # Only reorder if needed. + + for (nl=1; nl<=n1; nl=nl+1) { + r = (med - Mems[d[nl]+j]) / sigma + if (r < lsigma) + break + Memr[resid+nl] = r + } + for (nh=n1; nh>=1; nh=nh-1) { + r = (Mems[d[nh]+j] - med) / sigma + if (r < hsigma) + break + Memr[resid+nh] = r + } + n4 = nh - nl + 1 + + # If too many pixels are rejected add some back in. + # All pixels with the same residual are added. + while (n4 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n4 = nh - nl + 1 + } + + # If any pixels are rejected recompute the median. + if (nl > 1 || nh < n1) { + n5 = nl + n4 / 2 + if (mod (n4, 2) == 0) { + med = Mems[d[n5-1]+j] + med = (med + Mems[d[n5]+j]) / 2. + } else + med = Mems[d[n5]+j] + n[i] = n4 + } + if (combine == MEDIAN) + median[i] = med + + # Reorder if pixels only if necessary. + if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+j] = Mems[d[k]+j] + if (grow >= 1.) { + mp1 = m[l] + j + mp2 = m[k] + j + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+j] = Memi[m[k]+j] + k = k + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mems[d[l]+j] = Mems[d[k]+j] + k = k + 1 + } + } + } + } + + # Check if data flag needs to be reset for rejected pixels. + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag whether the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_PCLIP -- Percentile clip +# +# 1) Find the median +# 2) Find the pixel which is the specified order index away +# 3) Use the data value difference as a sigma and apply clipping +# 4) Since the median is known return it so it does not have to be recomputed + +procedure ic_pclipi (d, m, n, nimages, npts, median) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of input images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep +bool even, fp_equalr() +real sigma, r, s, t +pointer sp, resid, mp1, mp2 +real med + +include "../icombine.com" + +begin + # There must be at least MINCLIP and more than nkeep pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Set sign of pclip parameter + if (pclip < 0) + t = -1. + else + t = 1. + + # If there are no rejected pixels compute certain parameters once. + if (dflag == D_ALL) { + n1 = n[1] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0.) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + nin = n1 + } + + # Now apply clipping. + do i = 1, npts { + # Compute median. + if (dflag == D_MIX) { + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 == 0) { + if (combine == MEDIAN) + median[i] = blank + next + } + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + } + + j = i - 1 + if (even) { + med = Memi[d[n2-1]+j] + med = (med + Memi[d[n2]+j]) / 2. + } else + med = Memi[d[n2]+j] + + if (n1 < max (MINCLIP, maxkeep+1)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Define sigma for clipping + sigma = t * (Memi[d[n3]+j] - med) + if (fp_equalr (sigma, 0.)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Reject pixels and save residuals. + # Check if any pixels are clipped. + # If so recompute the median and reset the number of good pixels. + # Only reorder if needed. + + for (nl=1; nl<=n1; nl=nl+1) { + r = (med - Memi[d[nl]+j]) / sigma + if (r < lsigma) + break + Memr[resid+nl] = r + } + for (nh=n1; nh>=1; nh=nh-1) { + r = (Memi[d[nh]+j] - med) / sigma + if (r < hsigma) + break + Memr[resid+nh] = r + } + n4 = nh - nl + 1 + + # If too many pixels are rejected add some back in. + # All pixels with the same residual are added. + while (n4 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n4 = nh - nl + 1 + } + + # If any pixels are rejected recompute the median. + if (nl > 1 || nh < n1) { + n5 = nl + n4 / 2 + if (mod (n4, 2) == 0) { + med = Memi[d[n5-1]+j] + med = (med + Memi[d[n5]+j]) / 2. + } else + med = Memi[d[n5]+j] + n[i] = n4 + } + if (combine == MEDIAN) + median[i] = med + + # Reorder if pixels only if necessary. + if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memi[d[l]+j] = Memi[d[k]+j] + if (grow >= 1.) { + mp1 = m[l] + j + mp2 = m[k] + j + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+j] = Memi[m[k]+j] + k = k + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memi[d[l]+j] = Memi[d[k]+j] + k = k + 1 + } + } + } + } + + # Check if data flag needs to be reset for rejected pixels. + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag whether the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_PCLIP -- Percentile clip +# +# 1) Find the median +# 2) Find the pixel which is the specified order index away +# 3) Use the data value difference as a sigma and apply clipping +# 4) Since the median is known return it so it does not have to be recomputed + +procedure ic_pclipr (d, m, n, nimages, npts, median) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of input images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep +bool even, fp_equalr() +real sigma, r, s, t +pointer sp, resid, mp1, mp2 +real med + +include "../icombine.com" + +begin + # There must be at least MINCLIP and more than nkeep pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Set sign of pclip parameter + if (pclip < 0) + t = -1. + else + t = 1. + + # If there are no rejected pixels compute certain parameters once. + if (dflag == D_ALL) { + n1 = n[1] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0.) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + nin = n1 + } + + # Now apply clipping. + do i = 1, npts { + # Compute median. + if (dflag == D_MIX) { + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 == 0) { + if (combine == MEDIAN) + median[i] = blank + next + } + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + } + + j = i - 1 + if (even) { + med = Memr[d[n2-1]+j] + med = (med + Memr[d[n2]+j]) / 2. + } else + med = Memr[d[n2]+j] + + if (n1 < max (MINCLIP, maxkeep+1)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Define sigma for clipping + sigma = t * (Memr[d[n3]+j] - med) + if (fp_equalr (sigma, 0.)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Reject pixels and save residuals. + # Check if any pixels are clipped. + # If so recompute the median and reset the number of good pixels. + # Only reorder if needed. + + for (nl=1; nl<=n1; nl=nl+1) { + r = (med - Memr[d[nl]+j]) / sigma + if (r < lsigma) + break + Memr[resid+nl] = r + } + for (nh=n1; nh>=1; nh=nh-1) { + r = (Memr[d[nh]+j] - med) / sigma + if (r < hsigma) + break + Memr[resid+nh] = r + } + n4 = nh - nl + 1 + + # If too many pixels are rejected add some back in. + # All pixels with the same residual are added. + while (n4 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n4 = nh - nl + 1 + } + + # If any pixels are rejected recompute the median. + if (nl > 1 || nh < n1) { + n5 = nl + n4 / 2 + if (mod (n4, 2) == 0) { + med = Memr[d[n5-1]+j] + med = (med + Memr[d[n5]+j]) / 2. + } else + med = Memr[d[n5]+j] + n[i] = n4 + } + if (combine == MEDIAN) + median[i] = med + + # Reorder if pixels only if necessary. + if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+j] = Memr[d[k]+j] + if (grow >= 1.) { + mp1 = m[l] + j + mp2 = m[k] + j + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+j] = Memi[m[k]+j] + k = k + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memr[d[l]+j] = Memr[d[k]+j] + k = k + 1 + } + } + } + } + + # Check if data flag needs to be reset for rejected pixels. + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag whether the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_PCLIP -- Percentile clip +# +# 1) Find the median +# 2) Find the pixel which is the specified order index away +# 3) Use the data value difference as a sigma and apply clipping +# 4) Since the median is known return it so it does not have to be recomputed + +procedure ic_pclipd (d, m, n, nimages, npts, median) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of input images +int npts # Number of output points per line +double median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep +bool even, fp_equalr() +real sigma, r, s, t +pointer sp, resid, mp1, mp2 +double med + +include "../icombine.com" + +begin + # There must be at least MINCLIP and more than nkeep pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Set sign of pclip parameter + if (pclip < 0) + t = -1. + else + t = 1. + + # If there are no rejected pixels compute certain parameters once. + if (dflag == D_ALL) { + n1 = n[1] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0.) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + nin = n1 + } + + # Now apply clipping. + do i = 1, npts { + # Compute median. + if (dflag == D_MIX) { + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 == 0) { + if (combine == MEDIAN) + median[i] = blank + next + } + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + } + + j = i - 1 + if (even) { + med = Memd[d[n2-1]+j] + med = (med + Memd[d[n2]+j]) / 2. + } else + med = Memd[d[n2]+j] + + if (n1 < max (MINCLIP, maxkeep+1)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Define sigma for clipping + sigma = t * (Memd[d[n3]+j] - med) + if (fp_equalr (sigma, 0.)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Reject pixels and save residuals. + # Check if any pixels are clipped. + # If so recompute the median and reset the number of good pixels. + # Only reorder if needed. + + for (nl=1; nl<=n1; nl=nl+1) { + r = (med - Memd[d[nl]+j]) / sigma + if (r < lsigma) + break + Memr[resid+nl] = r + } + for (nh=n1; nh>=1; nh=nh-1) { + r = (Memd[d[nh]+j] - med) / sigma + if (r < hsigma) + break + Memr[resid+nh] = r + } + n4 = nh - nl + 1 + + # If too many pixels are rejected add some back in. + # All pixels with the same residual are added. + while (n4 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n4 = nh - nl + 1 + } + + # If any pixels are rejected recompute the median. + if (nl > 1 || nh < n1) { + n5 = nl + n4 / 2 + if (mod (n4, 2) == 0) { + med = Memd[d[n5-1]+j] + med = (med + Memd[d[n5]+j]) / 2. + } else + med = Memd[d[n5]+j] + n[i] = n4 + } + if (combine == MEDIAN) + median[i] = med + + # Reorder if pixels only if necessary. + if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memd[d[l]+j] = Memd[d[k]+j] + if (grow >= 1.) { + mp1 = m[l] + j + mp2 = m[k] + j + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+j] = Memi[m[k]+j] + k = k + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memd[d[l]+j] = Memd[d[k]+j] + k = k + 1 + } + } + } + } + + # Check if data flag needs to be reset for rejected pixels. + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag whether the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lscombine/src/generic/icsclip.x b/noao/twodspec/longslit/lscombine/src/generic/icsclip.x new file mode 100644 index 00000000..a0188d72 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icsclip.x @@ -0,0 +1,1922 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Mininum number of images for algorithm + + +# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average +# The initial average rejects the high and low pixels. A correction for +# different scalings of the images may be made. Weights are not used. + +procedure ic_asigclips (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, one +data one /1.0/ +pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Flag whether returned average needs to be recomputed. + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Save the residuals and the sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Do sigma clipping. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + + # If there are not enough pixels simply compute the average. + if (n1 < max (3, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mems[d[1]+k] + do j = 2, n1 + sum = sum + Mems[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + # Compute average with the high and low rejected. + low = Mems[d[1]+k] + high = Mems[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mems[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Iteratively reject pixels and compute the final average if needed. + # Compact the data and keep track of the image IDs if needed. + + repeat { + n2 = n1 + if (doscale1) { + # Compute sigma corrected for scaling. + s = 0. + wp = w - 1 + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Mems[dp1] + l = Memi[mp1] + r = sqrt (max (one, (a + zeros[l]) / scales[l])) + s = s + ((d1 - a) / r) ** 2 + Memr[wp] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + wp = w - 1 + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Mems[dp1] + r = (d1 - a) / (s * Memr[wp]) + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + Memr[wp] = Memr[w+n1-1] + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } else { + # Compute the sigma without scale correction. + s = 0. + do j = 1, n1 + s = s + (Mems[d[j]+k] - a) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Mems[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median + +procedure ic_msigclips (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, w, mp1, mp2 +real med, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Save the residuals and sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) + med = (Mems[d[n3-1]+k] + Mems[d[n3]+k]) / 2. + else + med = Mems[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + # Compute the sigma with scaling correction. + s = 0. + do j = nl, nh { + l = Memi[m[j]+k] + r = sqrt (max (one, (med + zeros[l]) / scales[l])) + s = s + ((Mems[d[j]+k] - med) / r) ** 2 + Memr[w+j-1] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= n2; nl = nl + 1) { + r = (med - Mems[d[nl]+k]) / (s * Memr[w+nl-1]) + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mems[d[nh]+k] - med) / (s * Memr[w+nh-1]) + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } else { + # Compute the sigma without scaling correction. + s = 0. + do j = nl, nh + s = s + (Mems[d[j]+k] - med) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= n2; nl = nl + 1) { + r = (med - Mems[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mems[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mems[d[l]+k] = Mems[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average +# The initial average rejects the high and low pixels. A correction for +# different scalings of the images may be made. Weights are not used. + +procedure ic_asigclipi (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, one +data one /1.0/ +pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Flag whether returned average needs to be recomputed. + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Save the residuals and the sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Do sigma clipping. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + + # If there are not enough pixels simply compute the average. + if (n1 < max (3, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memi[d[1]+k] + do j = 2, n1 + sum = sum + Memi[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + # Compute average with the high and low rejected. + low = Memi[d[1]+k] + high = Memi[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memi[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Iteratively reject pixels and compute the final average if needed. + # Compact the data and keep track of the image IDs if needed. + + repeat { + n2 = n1 + if (doscale1) { + # Compute sigma corrected for scaling. + s = 0. + wp = w - 1 + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memi[dp1] + l = Memi[mp1] + r = sqrt (max (one, (a + zeros[l]) / scales[l])) + s = s + ((d1 - a) / r) ** 2 + Memr[wp] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + wp = w - 1 + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memi[dp1] + r = (d1 - a) / (s * Memr[wp]) + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + Memr[wp] = Memr[w+n1-1] + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } else { + # Compute the sigma without scale correction. + s = 0. + do j = 1, n1 + s = s + (Memi[d[j]+k] - a) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memi[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median + +procedure ic_msigclipi (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, w, mp1, mp2 +real med, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Save the residuals and sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) + med = (Memi[d[n3-1]+k] + Memi[d[n3]+k]) / 2. + else + med = Memi[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + # Compute the sigma with scaling correction. + s = 0. + do j = nl, nh { + l = Memi[m[j]+k] + r = sqrt (max (one, (med + zeros[l]) / scales[l])) + s = s + ((Memi[d[j]+k] - med) / r) ** 2 + Memr[w+j-1] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= n2; nl = nl + 1) { + r = (med - Memi[d[nl]+k]) / (s * Memr[w+nl-1]) + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memi[d[nh]+k] - med) / (s * Memr[w+nh-1]) + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } else { + # Compute the sigma without scaling correction. + s = 0. + do j = nl, nh + s = s + (Memi[d[j]+k] - med) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= n2; nl = nl + 1) { + r = (med - Memi[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memi[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memi[d[l]+k] = Memi[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memi[d[l]+k] = Memi[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average +# The initial average rejects the high and low pixels. A correction for +# different scalings of the images may be made. Weights are not used. + +procedure ic_asigclipr (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, one +data one /1.0/ +pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Flag whether returned average needs to be recomputed. + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Save the residuals and the sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Do sigma clipping. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + + # If there are not enough pixels simply compute the average. + if (n1 < max (3, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memr[d[1]+k] + do j = 2, n1 + sum = sum + Memr[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + # Compute average with the high and low rejected. + low = Memr[d[1]+k] + high = Memr[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memr[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Iteratively reject pixels and compute the final average if needed. + # Compact the data and keep track of the image IDs if needed. + + repeat { + n2 = n1 + if (doscale1) { + # Compute sigma corrected for scaling. + s = 0. + wp = w - 1 + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memr[dp1] + l = Memi[mp1] + r = sqrt (max (one, (a + zeros[l]) / scales[l])) + s = s + ((d1 - a) / r) ** 2 + Memr[wp] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + wp = w - 1 + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memr[dp1] + r = (d1 - a) / (s * Memr[wp]) + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + Memr[wp] = Memr[w+n1-1] + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } else { + # Compute the sigma without scale correction. + s = 0. + do j = 1, n1 + s = s + (Memr[d[j]+k] - a) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memr[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median + +procedure ic_msigclipr (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, w, mp1, mp2 +real med, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Save the residuals and sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) + med = (Memr[d[n3-1]+k] + Memr[d[n3]+k]) / 2. + else + med = Memr[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + # Compute the sigma with scaling correction. + s = 0. + do j = nl, nh { + l = Memi[m[j]+k] + r = sqrt (max (one, (med + zeros[l]) / scales[l])) + s = s + ((Memr[d[j]+k] - med) / r) ** 2 + Memr[w+j-1] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= n2; nl = nl + 1) { + r = (med - Memr[d[nl]+k]) / (s * Memr[w+nl-1]) + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memr[d[nh]+k] - med) / (s * Memr[w+nh-1]) + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } else { + # Compute the sigma without scaling correction. + s = 0. + do j = nl, nh + s = s + (Memr[d[j]+k] - med) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= n2; nl = nl + 1) { + r = (med - Memr[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memr[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memr[d[l]+k] = Memr[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average +# The initial average rejects the high and low pixels. A correction for +# different scalings of the images may be made. Weights are not used. + +procedure ic_asigclipd (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +double average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +double d1, low, high, sum, a, s, r, one +data one /1.0D0/ +pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Flag whether returned average needs to be recomputed. + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Save the residuals and the sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Do sigma clipping. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + + # If there are not enough pixels simply compute the average. + if (n1 < max (3, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memd[d[1]+k] + do j = 2, n1 + sum = sum + Memd[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + # Compute average with the high and low rejected. + low = Memd[d[1]+k] + high = Memd[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memd[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Iteratively reject pixels and compute the final average if needed. + # Compact the data and keep track of the image IDs if needed. + + repeat { + n2 = n1 + if (doscale1) { + # Compute sigma corrected for scaling. + s = 0. + wp = w - 1 + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memd[dp1] + l = Memi[mp1] + r = sqrt (max (one, (a + zeros[l]) / scales[l])) + s = s + ((d1 - a) / r) ** 2 + Memr[wp] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + wp = w - 1 + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memd[dp1] + r = (d1 - a) / (s * Memr[wp]) + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + Memr[wp] = Memr[w+n1-1] + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } else { + # Compute the sigma without scale correction. + s = 0. + do j = 1, n1 + s = s + (Memd[d[j]+k] - a) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memd[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median + +procedure ic_msigclipd (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +double median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, w, mp1, mp2 +double med, one +data one /1.0D0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Save the residuals and sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) + med = (Memd[d[n3-1]+k] + Memd[d[n3]+k]) / 2. + else + med = Memd[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + # Compute the sigma with scaling correction. + s = 0. + do j = nl, nh { + l = Memi[m[j]+k] + r = sqrt (max (one, (med + zeros[l]) / scales[l])) + s = s + ((Memd[d[j]+k] - med) / r) ** 2 + Memr[w+j-1] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= n2; nl = nl + 1) { + r = (med - Memd[d[nl]+k]) / (s * Memr[w+nl-1]) + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memd[d[nh]+k] - med) / (s * Memr[w+nh-1]) + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } else { + # Compute the sigma without scaling correction. + s = 0. + do j = nl, nh + s = s + (Memd[d[j]+k] - med) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= n2; nl = nl + 1) { + r = (med - Memd[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memd[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memd[d[l]+k] = Memd[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memd[d[l]+k] = Memd[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lscombine/src/generic/icsigma.x b/noao/twodspec/longslit/lscombine/src/generic/icsigma.x new file mode 100644 index 00000000..b9c9a781 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icsigma.x @@ -0,0 +1,434 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + + +# IC_SIGMA -- Compute the sigma image line. +# The estimated sigma includes a correction for the finite population. +# Weights are used if desired. + +procedure ic_sigmas (d, m, n, wts, npts, average, sigma) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +real average[npts] # Average +real sigma[npts] # Sigma line (returned) + +int i, j, k, n1 +real wt, sigcor, sumwt +real a, sum + +include "../icombine.com" + +begin + if (dflag == D_ALL) { + n1 = n[1] + if (dowts) { + if (n1 > 1) + sigcor = real (n1) / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Mems[d[1]+k] - a) ** 2 * wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Mems[d[j]+k] - a) ** 2 * wt + } + sigma[i] = sqrt (sum * sigcor) + } + } else { + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + sum = (Mems[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mems[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } + } + } else if (dflag == D_NONE) { + do i = 1, npts + sigma[i] = blank + } else { + if (dowts) { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = real (n1) / real (n1 -1) + else + sigcor = 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Mems[d[1]+k] - a) ** 2 * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Mems[d[j]+k] - a) ** 2 * wt + sumwt = sumwt + wt + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Mems[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mems[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * sigcor) + } + } else + sigma[i] = blank + } + } else { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + a = average[i] + sum = (Mems[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mems[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } else + sigma[i] = blank + } + } + } +end + +# IC_SIGMA -- Compute the sigma image line. +# The estimated sigma includes a correction for the finite population. +# Weights are used if desired. + +procedure ic_sigmai (d, m, n, wts, npts, average, sigma) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +real average[npts] # Average +real sigma[npts] # Sigma line (returned) + +int i, j, k, n1 +real wt, sigcor, sumwt +real a, sum + +include "../icombine.com" + +begin + if (dflag == D_ALL) { + n1 = n[1] + if (dowts) { + if (n1 > 1) + sigcor = real (n1) / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memi[d[1]+k] - a) ** 2 * wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memi[d[j]+k] - a) ** 2 * wt + } + sigma[i] = sqrt (sum * sigcor) + } + } else { + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + sum = (Memi[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memi[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } + } + } else if (dflag == D_NONE) { + do i = 1, npts + sigma[i] = blank + } else { + if (dowts) { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = real (n1) / real (n1 -1) + else + sigcor = 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memi[d[1]+k] - a) ** 2 * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memi[d[j]+k] - a) ** 2 * wt + sumwt = sumwt + wt + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Memi[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memi[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * sigcor) + } + } else + sigma[i] = blank + } + } else { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + a = average[i] + sum = (Memi[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memi[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } else + sigma[i] = blank + } + } + } +end + +# IC_SIGMA -- Compute the sigma image line. +# The estimated sigma includes a correction for the finite population. +# Weights are used if desired. + +procedure ic_sigmar (d, m, n, wts, npts, average, sigma) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +real average[npts] # Average +real sigma[npts] # Sigma line (returned) + +int i, j, k, n1 +real wt, sigcor, sumwt +real a, sum + +include "../icombine.com" + +begin + if (dflag == D_ALL) { + n1 = n[1] + if (dowts) { + if (n1 > 1) + sigcor = real (n1) / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memr[d[1]+k] - a) ** 2 * wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memr[d[j]+k] - a) ** 2 * wt + } + sigma[i] = sqrt (sum * sigcor) + } + } else { + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + sum = (Memr[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memr[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } + } + } else if (dflag == D_NONE) { + do i = 1, npts + sigma[i] = blank + } else { + if (dowts) { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = real (n1) / real (n1 -1) + else + sigcor = 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memr[d[1]+k] - a) ** 2 * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memr[d[j]+k] - a) ** 2 * wt + sumwt = sumwt + wt + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Memr[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memr[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * sigcor) + } + } else + sigma[i] = blank + } + } else { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + a = average[i] + sum = (Memr[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memr[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } else + sigma[i] = blank + } + } + } +end + +# IC_SIGMA -- Compute the sigma image line. +# The estimated sigma includes a correction for the finite population. +# Weights are used if desired. + +procedure ic_sigmad (d, m, n, wts, npts, average, sigma) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +double average[npts] # Average +double sigma[npts] # Sigma line (returned) + +int i, j, k, n1 +real wt, sigcor, sumwt +double a, sum + +include "../icombine.com" + +begin + if (dflag == D_ALL) { + n1 = n[1] + if (dowts) { + if (n1 > 1) + sigcor = real (n1) / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memd[d[1]+k] - a) ** 2 * wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memd[d[j]+k] - a) ** 2 * wt + } + sigma[i] = sqrt (sum * sigcor) + } + } else { + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + sum = (Memd[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memd[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } + } + } else if (dflag == D_NONE) { + do i = 1, npts + sigma[i] = blank + } else { + if (dowts) { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = real (n1) / real (n1 -1) + else + sigcor = 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memd[d[1]+k] - a) ** 2 * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memd[d[j]+k] - a) ** 2 * wt + sumwt = sumwt + wt + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Memd[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memd[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * sigcor) + } + } else + sigma[i] = blank + } + } else { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + a = average[i] + sum = (Memd[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memd[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } else + sigma[i] = blank + } + } + } +end + diff --git a/noao/twodspec/longslit/lscombine/src/generic/icsort.x b/noao/twodspec/longslit/lscombine/src/generic/icsort.x new file mode 100644 index 00000000..3ec1d27e --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icsort.x @@ -0,0 +1,1096 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + + +# IC_SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. + +procedure ic_sorts (a, b, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +short b[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +short pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix + b[i] = Mems[a[i]+l] + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + + # General case + do i = 1, npix + b[i] = Mems[a[i]+l] + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix + Mems[a[i]+l] = b[i] + } +end + + +# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. A second integer set of +# vectors is sorted. + +procedure ic_2sorts (a, b, c, d, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +short b[ARB] # work array +pointer c[ARB] # pointer to associated integer vectors +int d[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +short pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp +define swap {temp=$1;$1=$2;$2=temp} +define iswap {itemp=$1;$1=$2;$2=itemp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix { + b[i] = Mems[a[i]+l] + d[i] = Memi[c[i]+l] + } + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + + # General case + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]); swap (d[j], d[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) { # out of order pair + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + } + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix { + Mems[a[i]+l] = b[i] + Memi[c[i]+l] = d[i] + } + } +end + +# IC_SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. + +procedure ic_sorti (a, b, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +int b[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +int pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix + b[i] = Memi[a[i]+l] + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + + # General case + do i = 1, npix + b[i] = Memi[a[i]+l] + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix + Memi[a[i]+l] = b[i] + } +end + + +# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. A second integer set of +# vectors is sorted. + +procedure ic_2sorti (a, b, c, d, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +int b[ARB] # work array +pointer c[ARB] # pointer to associated integer vectors +int d[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +int pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp +define swap {temp=$1;$1=$2;$2=temp} +define iswap {itemp=$1;$1=$2;$2=itemp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix { + b[i] = Memi[a[i]+l] + d[i] = Memi[c[i]+l] + } + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + + # General case + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]); swap (d[j], d[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) { # out of order pair + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + } + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix { + Memi[a[i]+l] = b[i] + Memi[c[i]+l] = d[i] + } + } +end + +# IC_SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. + +procedure ic_sortr (a, b, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +real b[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +real pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix + b[i] = Memr[a[i]+l] + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + + # General case + do i = 1, npix + b[i] = Memr[a[i]+l] + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix + Memr[a[i]+l] = b[i] + } +end + + +# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. A second integer set of +# vectors is sorted. + +procedure ic_2sortr (a, b, c, d, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +real b[ARB] # work array +pointer c[ARB] # pointer to associated integer vectors +int d[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +real pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp +define swap {temp=$1;$1=$2;$2=temp} +define iswap {itemp=$1;$1=$2;$2=itemp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix { + b[i] = Memr[a[i]+l] + d[i] = Memi[c[i]+l] + } + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + + # General case + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]); swap (d[j], d[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) { # out of order pair + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + } + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix { + Memr[a[i]+l] = b[i] + Memi[c[i]+l] = d[i] + } + } +end + +# IC_SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. + +procedure ic_sortd (a, b, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +double b[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +double pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix + b[i] = Memd[a[i]+l] + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + + # General case + do i = 1, npix + b[i] = Memd[a[i]+l] + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix + Memd[a[i]+l] = b[i] + } +end + + +# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. A second integer set of +# vectors is sorted. + +procedure ic_2sortd (a, b, c, d, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +double b[ARB] # work array +pointer c[ARB] # pointer to associated integer vectors +int d[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +double pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp +define swap {temp=$1;$1=$2;$2=temp} +define iswap {itemp=$1;$1=$2;$2=itemp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix { + b[i] = Memd[a[i]+l] + d[i] = Memi[c[i]+l] + } + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + + # General case + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]); swap (d[j], d[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) { # out of order pair + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + } + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix { + Memd[a[i]+l] = b[i] + Memi[c[i]+l] = d[i] + } + } +end diff --git a/noao/twodspec/longslit/lscombine/src/generic/icstat.x b/noao/twodspec/longslit/lscombine/src/generic/icstat.x new file mode 100644 index 00000000..3a0ed49c --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/icstat.x @@ -0,0 +1,892 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +define NMAX 100000 # Maximum number of pixels to sample + + +# IC_STAT -- Compute image statistics within specified section. +# The image section is relative to a reference image which may be +# different than the input image and may have an offset. Only a +# subsample of pixels is used. Masked and thresholded pixels are +# ignored. Only the desired statistics are computed to increase +# efficiency. + +procedure ic_stats (im, imref, section, offsets, image, nimages, + domode, domedian, domean, mode, median, mean) + +pointer im # Data image +pointer imref # Reference image for image section +char section[ARB] # Image section +int offsets[nimages,ARB] # Image section offset from data to reference +int image # Image index (for mask I/O) +int nimages # Number of images in offsets. +bool domode, domedian, domean # Statistics to compute +real mode, median, mean # Statistics + +int i, j, ndim, n, nv +real a +pointer sp, v1, v2, dv, va, vb +pointer data, mask, dp, lp, mp, imgnls() + +real asums() +short ic_modes() + +include "../icombine.com" + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (dv, IM_MAXDIM, TY_LONG) + call salloc (va, IM_MAXDIM, TY_LONG) + call salloc (vb, IM_MAXDIM, TY_LONG) + + # Determine the image section parameters. This must be in terms of + # the data image pixel coordinates though the section may be specified + # in terms of the reference image coordinates. Limit the number of + # pixels in each dimension to a maximum. + + ndim = IM_NDIM(im) + if (project) + ndim = ndim - 1 + call amovki (1, Memi[v1], IM_MAXDIM) + call amovki (1, Memi[va], IM_MAXDIM) + call amovki (1, Memi[dv], IM_MAXDIM) + call amovi (IM_LEN(imref,1), Memi[vb], ndim) + call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) + if (im != imref) + do i = 1, ndim { + Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] + Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] + } + + do j = 1, 10 { + n = 1 + do i = 0, ndim-1 { + Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) + Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) + Memi[dv+i] = j + nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] + n = n * nv + } + if (n < NMAX) + break + } + + call amovl (Memi[v1], Memi[va], IM_MAXDIM) + Memi[va] = 1 + if (project) + Memi[va+ndim] = image + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + + # Accumulate the pixel values within the section. Masked pixels and + # thresholded pixels are ignored. + + call salloc (data, n, TY_SHORT) + dp = data + while (imgnls (im, lp, Memi[vb]) != EOF) { + call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) + lp = lp + Memi[v1] - 1 + if (dflag == D_ALL) { + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + a = Mems[lp] + if (a >= lthresh && a <= hthresh) { + Mems[dp] = a + dp = dp + 1 + } + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + Mems[dp] = Mems[lp] + dp = dp + 1 + lp = lp + Memi[dv] + } + } + } else if (dflag == D_MIX) { + mp = mask + Memi[v1] - 1 + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + a = Mems[lp] + if (a >= lthresh && a <= hthresh) { + Mems[dp] = a + dp = dp + 1 + } + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + Mems[dp] = Mems[lp] + dp = dp + 1 + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } + } + for (i=2; i<=ndim; i=i+1) { + Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] + if (Memi[va+i-1] <= Memi[v2+i-1]) + break + Memi[va+i-1] = Memi[v1+i-1] + } + if (i > ndim) + break + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + n = dp - data + if (n < 1) { + call sfree (sp) + call error (1, "Image section contains no pixels") + } + + # Compute only statistics needed. + if (domode || domedian) { + call asrts (Mems[data], Mems[data], n) + mode = ic_modes (Mems[data], n) + median = Mems[data+n/2-1] + } + if (domean) + mean = asums (Mems[data], n) / n + + call sfree (sp) +end + + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZRANGE 0.7 # Fraction of pixels about median to use +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + +# IC_MODE -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +short procedure ic_modes (a, n) + +short a[n] # Data array +int n # Number of points + +int i, j, k, nmax +real z1, z2, zstep, zbin +short mode +bool fp_equalr() + +begin + if (n < NMIN) + return (a[n/2]) + + # Compute the mode. The array must be sorted. Consider a + # range of values about the median point. Use a bin size which + # is ZBIN of the range. Step the bin limits in ZSTEP fraction of + # the bin size. + + i = 1 + n * (1. - ZRANGE) / 2. + j = 1 + n * (1. + ZRANGE) / 2. + z1 = a[i] + z2 = a[j] + if (fp_equalr (z1, z2)) { + mode = z1 + return (mode) + } + + zstep = ZSTEP * (z2 - z1) + zbin = ZBIN * (z2 - z1) + 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 && a[i] < z1; i=i+1) + ; + for (; k < j && a[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = a[(i+k)/2] + } + } until (k >= j) + + return (mode) +end + +# IC_STAT -- Compute image statistics within specified section. +# The image section is relative to a reference image which may be +# different than the input image and may have an offset. Only a +# subsample of pixels is used. Masked and thresholded pixels are +# ignored. Only the desired statistics are computed to increase +# efficiency. + +procedure ic_stati (im, imref, section, offsets, image, nimages, + domode, domedian, domean, mode, median, mean) + +pointer im # Data image +pointer imref # Reference image for image section +char section[ARB] # Image section +int offsets[nimages,ARB] # Image section offset from data to reference +int image # Image index (for mask I/O) +int nimages # Number of images in offsets. +bool domode, domedian, domean # Statistics to compute +real mode, median, mean # Statistics + +int i, j, ndim, n, nv +real a +pointer sp, v1, v2, dv, va, vb +pointer data, mask, dp, lp, mp, imgnli() + +real asumi() +int ic_modei() + +include "../icombine.com" + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (dv, IM_MAXDIM, TY_LONG) + call salloc (va, IM_MAXDIM, TY_LONG) + call salloc (vb, IM_MAXDIM, TY_LONG) + + # Determine the image section parameters. This must be in terms of + # the data image pixel coordinates though the section may be specified + # in terms of the reference image coordinates. Limit the number of + # pixels in each dimension to a maximum. + + ndim = IM_NDIM(im) + if (project) + ndim = ndim - 1 + call amovki (1, Memi[v1], IM_MAXDIM) + call amovki (1, Memi[va], IM_MAXDIM) + call amovki (1, Memi[dv], IM_MAXDIM) + call amovi (IM_LEN(imref,1), Memi[vb], ndim) + call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) + if (im != imref) + do i = 1, ndim { + Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] + Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] + } + + do j = 1, 10 { + n = 1 + do i = 0, ndim-1 { + Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) + Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) + Memi[dv+i] = j + nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] + n = n * nv + } + if (n < NMAX) + break + } + + call amovl (Memi[v1], Memi[va], IM_MAXDIM) + Memi[va] = 1 + if (project) + Memi[va+ndim] = image + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + + # Accumulate the pixel values within the section. Masked pixels and + # thresholded pixels are ignored. + + call salloc (data, n, TY_INT) + dp = data + while (imgnli (im, lp, Memi[vb]) != EOF) { + call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) + lp = lp + Memi[v1] - 1 + if (dflag == D_ALL) { + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + a = Memi[lp] + if (a >= lthresh && a <= hthresh) { + Memi[dp] = a + dp = dp + 1 + } + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + Memi[dp] = Memi[lp] + dp = dp + 1 + lp = lp + Memi[dv] + } + } + } else if (dflag == D_MIX) { + mp = mask + Memi[v1] - 1 + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + a = Memi[lp] + if (a >= lthresh && a <= hthresh) { + Memi[dp] = a + dp = dp + 1 + } + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + Memi[dp] = Memi[lp] + dp = dp + 1 + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } + } + for (i=2; i<=ndim; i=i+1) { + Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] + if (Memi[va+i-1] <= Memi[v2+i-1]) + break + Memi[va+i-1] = Memi[v1+i-1] + } + if (i > ndim) + break + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + n = dp - data + if (n < 1) { + call sfree (sp) + call error (1, "Image section contains no pixels") + } + + # Compute only statistics needed. + if (domode || domedian) { + call asrti (Memi[data], Memi[data], n) + mode = ic_modei (Memi[data], n) + median = Memi[data+n/2-1] + } + if (domean) + mean = asumi (Memi[data], n) / n + + call sfree (sp) +end + + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZRANGE 0.7 # Fraction of pixels about median to use +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + +# IC_MODE -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +int procedure ic_modei (a, n) + +int a[n] # Data array +int n # Number of points + +int i, j, k, nmax +real z1, z2, zstep, zbin +int mode +bool fp_equalr() + +begin + if (n < NMIN) + return (a[n/2]) + + # Compute the mode. The array must be sorted. Consider a + # range of values about the median point. Use a bin size which + # is ZBIN of the range. Step the bin limits in ZSTEP fraction of + # the bin size. + + i = 1 + n * (1. - ZRANGE) / 2. + j = 1 + n * (1. + ZRANGE) / 2. + z1 = a[i] + z2 = a[j] + if (fp_equalr (z1, z2)) { + mode = z1 + return (mode) + } + + zstep = ZSTEP * (z2 - z1) + zbin = ZBIN * (z2 - z1) + 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 && a[i] < z1; i=i+1) + ; + for (; k < j && a[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = a[(i+k)/2] + } + } until (k >= j) + + return (mode) +end + +# IC_STAT -- Compute image statistics within specified section. +# The image section is relative to a reference image which may be +# different than the input image and may have an offset. Only a +# subsample of pixels is used. Masked and thresholded pixels are +# ignored. Only the desired statistics are computed to increase +# efficiency. + +procedure ic_statr (im, imref, section, offsets, image, nimages, + domode, domedian, domean, mode, median, mean) + +pointer im # Data image +pointer imref # Reference image for image section +char section[ARB] # Image section +int offsets[nimages,ARB] # Image section offset from data to reference +int image # Image index (for mask I/O) +int nimages # Number of images in offsets. +bool domode, domedian, domean # Statistics to compute +real mode, median, mean # Statistics + +int i, j, ndim, n, nv +real a +pointer sp, v1, v2, dv, va, vb +pointer data, mask, dp, lp, mp, imgnlr() + +real asumr() +real ic_moder() + +include "../icombine.com" + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (dv, IM_MAXDIM, TY_LONG) + call salloc (va, IM_MAXDIM, TY_LONG) + call salloc (vb, IM_MAXDIM, TY_LONG) + + # Determine the image section parameters. This must be in terms of + # the data image pixel coordinates though the section may be specified + # in terms of the reference image coordinates. Limit the number of + # pixels in each dimension to a maximum. + + ndim = IM_NDIM(im) + if (project) + ndim = ndim - 1 + call amovki (1, Memi[v1], IM_MAXDIM) + call amovki (1, Memi[va], IM_MAXDIM) + call amovki (1, Memi[dv], IM_MAXDIM) + call amovi (IM_LEN(imref,1), Memi[vb], ndim) + call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) + if (im != imref) + do i = 1, ndim { + Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] + Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] + } + + do j = 1, 10 { + n = 1 + do i = 0, ndim-1 { + Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) + Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) + Memi[dv+i] = j + nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] + n = n * nv + } + if (n < NMAX) + break + } + + call amovl (Memi[v1], Memi[va], IM_MAXDIM) + Memi[va] = 1 + if (project) + Memi[va+ndim] = image + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + + # Accumulate the pixel values within the section. Masked pixels and + # thresholded pixels are ignored. + + call salloc (data, n, TY_REAL) + dp = data + while (imgnlr (im, lp, Memi[vb]) != EOF) { + call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) + lp = lp + Memi[v1] - 1 + if (dflag == D_ALL) { + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + a = Memr[lp] + if (a >= lthresh && a <= hthresh) { + Memr[dp] = a + dp = dp + 1 + } + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + Memr[dp] = Memr[lp] + dp = dp + 1 + lp = lp + Memi[dv] + } + } + } else if (dflag == D_MIX) { + mp = mask + Memi[v1] - 1 + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + a = Memr[lp] + if (a >= lthresh && a <= hthresh) { + Memr[dp] = a + dp = dp + 1 + } + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + Memr[dp] = Memr[lp] + dp = dp + 1 + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } + } + for (i=2; i<=ndim; i=i+1) { + Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] + if (Memi[va+i-1] <= Memi[v2+i-1]) + break + Memi[va+i-1] = Memi[v1+i-1] + } + if (i > ndim) + break + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + n = dp - data + if (n < 1) { + call sfree (sp) + call error (1, "Image section contains no pixels") + } + + # Compute only statistics needed. + if (domode || domedian) { + call asrtr (Memr[data], Memr[data], n) + mode = ic_moder (Memr[data], n) + median = Memr[data+n/2-1] + } + if (domean) + mean = asumr (Memr[data], n) / n + + call sfree (sp) +end + + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZRANGE 0.7 # Fraction of pixels about median to use +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + +# IC_MODE -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +real procedure ic_moder (a, n) + +real a[n] # Data array +int n # Number of points + +int i, j, k, nmax +real z1, z2, zstep, zbin +real mode +bool fp_equalr() + +begin + if (n < NMIN) + return (a[n/2]) + + # Compute the mode. The array must be sorted. Consider a + # range of values about the median point. Use a bin size which + # is ZBIN of the range. Step the bin limits in ZSTEP fraction of + # the bin size. + + i = 1 + n * (1. - ZRANGE) / 2. + j = 1 + n * (1. + ZRANGE) / 2. + z1 = a[i] + z2 = a[j] + if (fp_equalr (z1, z2)) { + mode = z1 + return (mode) + } + + zstep = ZSTEP * (z2 - z1) + zbin = ZBIN * (z2 - z1) + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && a[i] < z1; i=i+1) + ; + for (; k < j && a[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = a[(i+k)/2] + } + } until (k >= j) + + return (mode) +end + +# IC_STAT -- Compute image statistics within specified section. +# The image section is relative to a reference image which may be +# different than the input image and may have an offset. Only a +# subsample of pixels is used. Masked and thresholded pixels are +# ignored. Only the desired statistics are computed to increase +# efficiency. + +procedure ic_statd (im, imref, section, offsets, image, nimages, + domode, domedian, domean, mode, median, mean) + +pointer im # Data image +pointer imref # Reference image for image section +char section[ARB] # Image section +int offsets[nimages,ARB] # Image section offset from data to reference +int image # Image index (for mask I/O) +int nimages # Number of images in offsets. +bool domode, domedian, domean # Statistics to compute +real mode, median, mean # Statistics + +int i, j, ndim, n, nv +real a +pointer sp, v1, v2, dv, va, vb +pointer data, mask, dp, lp, mp, imgnld() + +double asumd() +double ic_moded() + +include "../icombine.com" + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (dv, IM_MAXDIM, TY_LONG) + call salloc (va, IM_MAXDIM, TY_LONG) + call salloc (vb, IM_MAXDIM, TY_LONG) + + # Determine the image section parameters. This must be in terms of + # the data image pixel coordinates though the section may be specified + # in terms of the reference image coordinates. Limit the number of + # pixels in each dimension to a maximum. + + ndim = IM_NDIM(im) + if (project) + ndim = ndim - 1 + call amovki (1, Memi[v1], IM_MAXDIM) + call amovki (1, Memi[va], IM_MAXDIM) + call amovki (1, Memi[dv], IM_MAXDIM) + call amovi (IM_LEN(imref,1), Memi[vb], ndim) + call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) + if (im != imref) + do i = 1, ndim { + Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] + Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] + } + + do j = 1, 10 { + n = 1 + do i = 0, ndim-1 { + Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) + Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) + Memi[dv+i] = j + nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] + n = n * nv + } + if (n < NMAX) + break + } + + call amovl (Memi[v1], Memi[va], IM_MAXDIM) + Memi[va] = 1 + if (project) + Memi[va+ndim] = image + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + + # Accumulate the pixel values within the section. Masked pixels and + # thresholded pixels are ignored. + + call salloc (data, n, TY_DOUBLE) + dp = data + while (imgnld (im, lp, Memi[vb]) != EOF) { + call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) + lp = lp + Memi[v1] - 1 + if (dflag == D_ALL) { + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + a = Memd[lp] + if (a >= lthresh && a <= hthresh) { + Memd[dp] = a + dp = dp + 1 + } + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + Memd[dp] = Memd[lp] + dp = dp + 1 + lp = lp + Memi[dv] + } + } + } else if (dflag == D_MIX) { + mp = mask + Memi[v1] - 1 + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + a = Memd[lp] + if (a >= lthresh && a <= hthresh) { + Memd[dp] = a + dp = dp + 1 + } + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + Memd[dp] = Memd[lp] + dp = dp + 1 + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } + } + for (i=2; i<=ndim; i=i+1) { + Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] + if (Memi[va+i-1] <= Memi[v2+i-1]) + break + Memi[va+i-1] = Memi[v1+i-1] + } + if (i > ndim) + break + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + n = dp - data + if (n < 1) { + call sfree (sp) + call error (1, "Image section contains no pixels") + } + + # Compute only statistics needed. + if (domode || domedian) { + call asrtd (Memd[data], Memd[data], n) + mode = ic_moded (Memd[data], n) + median = Memd[data+n/2-1] + } + if (domean) + mean = asumd (Memd[data], n) / n + + call sfree (sp) +end + + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZRANGE 0.7 # Fraction of pixels about median to use +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + +# IC_MODE -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +double procedure ic_moded (a, n) + +double a[n] # Data array +int n # Number of points + +int i, j, k, nmax +real z1, z2, zstep, zbin +double mode +bool fp_equalr() + +begin + if (n < NMIN) + return (a[n/2]) + + # Compute the mode. The array must be sorted. Consider a + # range of values about the median point. Use a bin size which + # is ZBIN of the range. Step the bin limits in ZSTEP fraction of + # the bin size. + + i = 1 + n * (1. - ZRANGE) / 2. + j = 1 + n * (1. + ZRANGE) / 2. + z1 = a[i] + z2 = a[j] + if (fp_equalr (z1, z2)) { + mode = z1 + return (mode) + } + + zstep = ZSTEP * (z2 - z1) + zbin = ZBIN * (z2 - z1) + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && a[i] < z1; i=i+1) + ; + for (; k < j && a[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = a[(i+k)/2] + } + } until (k >= j) + + return (mode) +end + diff --git a/noao/twodspec/longslit/lscombine/src/generic/mkpkg b/noao/twodspec/longslit/lscombine/src/generic/mkpkg new file mode 100644 index 00000000..b05b48a6 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/mkpkg @@ -0,0 +1,25 @@ +# Make IMCOMBINE. + +$checkout libpkg.a ../../../../ +$update libpkg.a +$checkin libpkg.a ../../../../ +$exit + +libpkg.a: + icaclip.x ../icombine.com ../icombine.h + icaverage.x ../icombine.com ../icombine.h <imhdr.h> + iccclip.x ../icombine.com ../icombine.h + icgdata.x ../icombine.com ../icombine.h <imhdr.h> <mach.h> + icgrow.x ../icombine.com ../icombine.h <imhdr.h> <pmset.h> + icmedian.x ../icombine.com ../icombine.h + icmm.x ../icombine.com ../icombine.h + icomb.x ../icombine.com ../icombine.h <error.h> <imhdr.h>\ + <imset.h> <mach.h> <pmset.h> <syserr.h> + icpclip.x ../icombine.com ../icombine.h + icsclip.x ../icombine.com ../icombine.h + icsigma.x ../icombine.com ../icombine.h <imhdr.h> + icsort.x + icstat.x ../icombine.com ../icombine.h <imhdr.h> + + xtimmap.x ../xtimmap.com <config.h> <error.h> <imhdr.h> <imset.h> + ; diff --git a/noao/twodspec/longslit/lscombine/src/generic/xtimmap.x b/noao/twodspec/longslit/lscombine/src/generic/xtimmap.x new file mode 100644 index 00000000..9e86e44d --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/generic/xtimmap.x @@ -0,0 +1,1080 @@ +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imset.h> +include <config.h> + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include <imset.h> + +# These routines maintain an arbitrary number of indexed "open" images which +# must be READ_ONLY. The calling program may use the returned pointer for +# header accesses but must call xt_opix before I/O. Subsequent calls to +# xt_opix may invalidate the pointer. The xt_imunmap call will free memory. + +define MAX_OPENIM (LAST_FD-16) # Maximum images kept open +define MAX_OPENPIX 45 # Maximum pixel files kept open + +define XT_SZIMNAME 299 # Size of IMNAME string +define XT_LEN 179 # Structure length +define XT_IMNAME Memc[P2C($1)] # Image name +define XT_ARG Memi[$1+150] # IMMAP header argument +define XT_IM Memi[$1+151] # IMIO pointer +define XT_HDR Memi[$1+152] # Copy of IMIO pointer +define XT_CLOSEFD Memi[$1+153] # Close FD? +define XT_FLAG Memi[$1+154] # Flag +define XT_BUFSIZE Memi[$1+155] # Buffer size +define XT_BUF Memi[$1+156] # Data buffer +define XT_BTYPE Memi[$1+157] # Data buffer type +define XT_VS Memi[$1+157+$2] # Start vector (10) +define XT_VE Memi[$1+167+$2] # End vector (10) + +# Options +define XT_MAPUNMAP 1 # Map and unmap images. + +# XT_IMMAP -- Map an image and save it as an indexed open image. +# The returned pointer may be used for header access but not I/O. +# The indexed image is closed by xt_imunmap. + +pointer procedure xt_immap (imname, acmode, hdr_arg, index) + +char imname[ARB] #I Image name +int acmode #I Access mode +int hdr_arg #I Header argument +int index #I Save index +pointer im #O Image pointer (returned) + +int i, envgeti() +pointer xt, xt_opix() +errchk xt_opix + +int first_time +data first_time /YES/ + +include "../xtimmap.com" + +begin + if (acmode != READ_ONLY) + call error (1, "XT_IMMAP: Only READ_ONLY allowed") + + # Initialize once per process. + if (first_time == YES) { + iferr (option = envgeti ("imcombine_option")) + option = 1 + min_open = 1 + nopen = 0 + nopenpix = 0 + nalloc = MAX_OPENIM + call calloc (ims, nalloc, TY_POINTER) + first_time = NO + } + + # Free image if needed. + call xt_imunmap (NULL, index) + + # Allocate structure. + if (index > nalloc) { + i = nalloc + nalloc = index + MAX_OPENIM + call realloc (ims, nalloc, TY_STRUCT) + call amovki (NULL, Memi[ims+i], nalloc-i) + } + call calloc (xt, XT_LEN, TY_STRUCT) + Memi[ims+index-1] = xt + + # Initialize. + call strcpy (imname, XT_IMNAME(xt), XT_SZIMNAME) + XT_ARG(xt) = hdr_arg + XT_IM(xt) = NULL + XT_HDR(xt) = NULL + + # Open image. + last_flag = 0 + im = xt_opix (NULL, index, 0) + + # Make copy of IMIO pointer for header keyword access. + call malloc (XT_HDR(xt), LEN_IMDES+IM_HDRLEN(im)+1, TY_STRUCT) + call amovi (Memi[im], Memi[XT_HDR(xt)], LEN_IMDES) + call amovi (IM_MAGIC(im), IM_MAGIC(XT_HDR(xt)), IM_HDRLEN(im)+1) + + return (XT_HDR(xt)) +end + + +# XT_OPIX -- Open the image for I/O. +# If the image has not been mapped return the default pointer. + +pointer procedure xt_opix (imdef, index, flag) + +int index #I index +pointer imdef #I Default pointer +int flag #I Flag + +int i, open(), imstati() +pointer im, xt, xt1, immap() +errchk open, immap, imunmap + +include "../xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imdef) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Return pointer for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (im) + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= MAX_OPENIM) { + if (option == XT_MAPUNMAP || flag == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + if (!IS_INDEFI(XT_BUFSIZE(xt))) + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + else + XT_BUFSIZE(xt) = imstati (im, IM_BUFSIZE) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (im) +end + + +# XT_CPIX -- Close image. + +procedure xt_cpix (index) + +int index #I index + +pointer xt +errchk imunmap + +include "../xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) + return + + if (XT_IM(xt) != NULL) { + call imunmap (XT_IM(xt)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + } + call mfree (XT_BUF(xt), XT_BTYPE(xt)) +end + + +# XT_IMSETI -- Set IMIO value. + +procedure xt_imseti (index, param, value) + +int index #I index +int param #I IMSET parameter +int value #I Value + +pointer xt +bool streq() + +include "../xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) { + if (streq (param, "option")) + option = value + } else { + if (streq (param, "bufsize")) { + XT_BUFSIZE(xt) = value + if (XT_IM(xt) != NULL) { + call imseti (XT_IM(xt), IM_BUFFRAC, 0) + call imseti (XT_IM(xt), IM_BUFSIZE, value) + } + } + } +end + + +# XT_IMUNMAP -- Unmap indexed open image. +# The header pointer is set to NULL to indicate the image has been closed. + +procedure xt_imunmap (im, index) + +int im #U IMIO header pointer +int index #I index + +pointer xt +errchk imunmap + +include "../xtimmap.com" + +begin + # Check for an indexed image. If it is not unmap the pointer + # as a regular IMIO pointer. + + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + if (xt == NULL) { + if (im != NULL) + call imunmap (im) + return + } + + # Close indexed image. + if (XT_IM(xt) != NULL) { + iferr (call imunmap (XT_IM(xt))) { + XT_IM(xt) = NULL + call erract (EA_WARN) + } + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + if (index == min_open) + min_open = 1 + } + + # Free any buffered memory. + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + + # Free header pointer. Note that if the supplied pointer is not + # header pointer then it is not set to NULL. + if (XT_HDR(xt) == im) + im = NULL + call mfree (XT_HDR(xt), TY_STRUCT) + + # Free save structure. + call mfree (Memi[ims+index-1], TY_STRUCT) + Memi[ims+index-1] = NULL +end + + +# XT_REINDEX -- Reindex open images. +# This is used when some images are closed by xt_imunmap. It is up to +# the calling program to reindex the header pointers and to subsequently +# use the new index values. + +procedure xt_reindex () + +int old, new + +include "../xtimmap.com" + +begin + new = 0 + do old = 0, nalloc-1 { + if (Memi[ims+old] == NULL) + next + Memi[ims+new] = Memi[ims+old] + new = new + 1 + } + do old = new, nalloc-1 + Memi[ims+old] = NULL +end + + + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnls (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnls(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggss() +errchk open, immap, imgnls, imggss, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "../xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnls (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnls (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_SHORT) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= MAX_OPENIM) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_SHORT) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_SHORT + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggss (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovs (Mems[ptr], Mems[XT_BUF(xt1)], nl*nc) + } + + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnls (im, buf, v)) +end + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnli (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnli(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggsi() +errchk open, immap, imgnli, imggsi, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "../xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnli (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnli (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_INT) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= MAX_OPENIM) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_INT) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_INT + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggsi (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovi (Memi[ptr], Memi[XT_BUF(xt1)], nl*nc) + } + + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnli (im, buf, v)) +end + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnlr (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnlr(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggsr() +errchk open, immap, imgnlr, imggsr, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "../xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnlr (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnlr (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_REAL) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= MAX_OPENIM) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_REAL) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_REAL + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggsr (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovr (Memr[ptr], Memr[XT_BUF(xt1)], nl*nc) + } + + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnlr (im, buf, v)) +end + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnld (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnld(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggsd() +errchk open, immap, imgnld, imggsd, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "../xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnld (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnld (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_DOUBLE) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= MAX_OPENIM) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_DOUBLE) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_DOUBLE + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggsd (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovd (Memd[ptr], Memd[XT_BUF(xt1)], nl*nc) + } + + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnld (im, buf, v)) +end + diff --git a/noao/twodspec/longslit/lscombine/src/icaclip.gx b/noao/twodspec/longslit/lscombine/src/icaclip.gx new file mode 100644 index 00000000..696402b2 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icaclip.gx @@ -0,0 +1,575 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Minimum number of images for this algorithm + +$for (sird) +# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_aavsigclip$t (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real average[npts] # Average +$else +PIXEL average[npts] # Average +$endif + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +$if (datatype == sil) +real d1, low, high, sum, a, s, s1, r, one +data one /1.0/ +$else +PIXEL d1, low, high, sum, a, s, s1, r, one +data one /1$f/ +$endif +pointer sp, sums, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (sums, npts, TY_REAL) + call salloc (resid, nimages+1, TY_REAL) + + # Since the unweighted average is computed here possibly skip combining + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Compute the unweighted average with the high and low rejected and + # the poisson scaled average sigma. There must be at least three + # pixels at each point to define the average and contributions to + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + nin = n[1] + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 < 3) + next + + # Unweighted average with the high and low rejected + low = Mem$t[d[1]+k] + high = Mem$t[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mem$t[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Mem$t[dp1] + l = Memi[mp1] + s1 = max (one, (a + zeros[l]) / scales[l]) + s = s + (d1 - a) ** 2 / s1 + } + } else { + s1 = max (one, a) + do j = 1, n1 + s = s + (Mem$t[d[j]+k] - a) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the average and sum for later. + average[i] = a + Memr[sums+k] = sum + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + + # Reject pixels and compute the final average (if needed). + # There must be at least three pixels at each point for rejection. + # Iteratively scale the mean sigma and reject pixels + # Compact the data and keep track of the image IDs if needed. + + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (2, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mem$t[d[1]+k] + do j = 2, n1 + sum = sum + Mem$t[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + a = average[i] + sum = Memr[sums+k] + + repeat { + n2 = n1 + if (s > 0.) { + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Mem$t[dp1] + l = Memi[mp1] + s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + s1 = s * sqrt (max (one, a)) + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Mem$t[dp1] + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_mavsigclip$t (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real median[npts] # Median +$else +PIXEL median[npts] # Median +$endif + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +pointer sp, resid, mp1, mp2 +$if (datatype == sil) +real med, low, high, r, s, s1, one +data one /1.0/ +$else +PIXEL med, low, high, r, s, s1, one +data one /1$f/ +$endif + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute the poisson scaled average sigma about the median. + # There must be at least three pixels at each point to define + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + s = 0. + n2 = 0 + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 < 3) { + if (n1 == 0) + median[i] = blank + else if (n1 == 1) + median[i] = Mem$t[d[1]+k] + else { + low = Mem$t[d[1]+k] + high = Mem$t[d[2]+k] + median[i] = (low + high) / 2. + } + next + } + + # Median + n3 = 1 + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mem$t[d[n3-1]+k] + high = Mem$t[d[n3]+k] + med = (low + high) / 2. + } else + med = Mem$t[d[n3]+k] + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + l = Memi[m[j]+k] + s1 = max (one, (med + zeros[l]) / scales[l]) + s = s + (Mem$t[d[j]+k] - med) ** 2 / s1 + } + } else { + s1 = max (one, med) + do j = 1, n1 + s = s + (Mem$t[d[j]+k] - med) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the median for later. + median[i] = med + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 < max (3, maxkeep+1)) + next + nl = 1 + nh = n1 + med = median[i] + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 >= max (MINCLIP, maxkeep+1) && s > 0.) { + if (doscale1) { + for (; nl <= n2; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = s * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (med - Mem$t[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s1 = s * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (Mem$t[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + s1 = s * sqrt (max (one, med)) + for (; nl <= n2; nl = nl + 1) { + r = (med - Mem$t[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mem$t[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mem$t[d[n3-1]+k] + high = Mem$t[d[n3]+k] + med = (low + high) / 2. + } else + med = Mem$t[d[n3]+k] + } else + med = blank + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mem$t[d[n3-1]+k] + high = Mem$t[d[n3]+k] + med = (low + high) / 2. + } else + med = Mem$t[d[n3]+k] + } else + med = blank + } + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/icaverage.gx b/noao/twodspec/longslit/lscombine/src/icaverage.gx new file mode 100644 index 00000000..a95b7673 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icaverage.gx @@ -0,0 +1,114 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +$for (sird) +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_average$t (d, m, n, wts, npts, doblank, doaverage, average) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +$if (datatype == sil) +real average[npts] # Average (returned) +$else +PIXEL average[npts] # Average (returned) +$endif + +int i, j, k +real sumwt, wt +$if (datatype == sil) +real sum +$else +PIXEL sum +$endif + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts) { + do i = 1, npts { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Mem$t[d[1]+k] * wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Mem$t[d[j]+k] * wt + } + average[i] = sum + } + } else { + do i = 1, npts { + k = i - 1 + sum = Mem$t[d[1]+k] + do j = 2, n[i] + sum = sum + Mem$t[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts) { + do i = 1, npts { + if (n[i] > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Mem$t[d[1]+k] * wt + sumwt = wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Mem$t[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Mem$t[d[1]+k] + do j = 2, n[i] + sum = sum + Mem$t[d[j]+k] + average[i] = sum / n[i] + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + if (n[i] > 0) { + k = i - 1 + sum = Mem$t[d[1]+k] + do j = 2, n[i] + sum = sum + Mem$t[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/iccclip.gx b/noao/twodspec/longslit/lscombine/src/iccclip.gx new file mode 100644 index 00000000..609b3448 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/iccclip.gx @@ -0,0 +1,471 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 2 # Mininum number of images for algorithm + +$for (sird) +# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average + +procedure ic_accdclip$t (d, m, n, scales, zeros, nm, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model parameters +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real average[npts] # Average +$else +PIXEL average[npts] # Average +$endif + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +$if (datatype == sil) +real d1, low, high, sum, a, s, r, zero +data zero /0.0/ +$else +PIXEL d1, low, high, sum, a, s, r, zero +data zero /0$f/ +$endif +pointer sp, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are no pixels go on to the combining. Since the unweighted + # average is computed here possibly skip the combining later. + + # There must be at least max (1, nkeep) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } else if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # There must be at least two pixels for rejection. The initial + # average is the low/high rejected average except in the case of + # just two pixels. The rejections are iterated and the average + # is recomputed. Corrections for scaling may be performed. + # Depending on other flags the image IDs may also need to be adjusted. + + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (MINCLIP-1, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mem$t[d[1]+k] + do j = 2, n1 + sum = sum + Mem$t[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + repeat { + if (n1 == 2) { + sum = Mem$t[d[1]+k] + sum = sum + Mem$t[d[2]+k] + a = sum / 2 + } else { + low = Mem$t[d[1]+k] + high = Mem$t[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mem$t[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + } + n2 = n1 + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + l = Memi[mp1] + s = scales[l] + d1 = max (zero, s * (a + zeros[l])) + s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s + + d1 = Mem$t[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + if (!keepids) { + s = max (zero, a) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (j=1; j<=n1; j=j+1) { + if (keepids) { + l = Memi[m[j]+k] + s = max (zero, a) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + dp1 = d[j] + k + d1 = Mem$t[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + } + + n[i] = n1 + if (!docombine) + if (n1 > 0) + average[i] = sum / n1 + else + average[i] = blank + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median + +procedure ic_mccdclip$t (d, m, n, scales, zeros, nm, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real median[npts] # Median +$else +PIXEL median[npts] # Median +$endif + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, mp1, mp2 +$if (datatype == sil) +real med, zero +data zero /0.0/ +$else +PIXEL med, zero +data zero /0$f/ +$endif + +include "../icombine.com" + +begin + # There must be at least max (MINCLIP, nkeep+1) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) { + med = Mem$t[d[n3-1]+k] + med = (med + Mem$t[d[n3]+k]) / 2. + } else + med = Mem$t[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + for (; nl <= n2; nl = nl + 1) { + l = Memi[m[nl]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (med - Mem$t[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (Mem$t[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + if (!keepids) { + s = max (zero, med) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (; nl <= n2; nl = nl + 1) { + if (keepids) { + l = Memi[m[nl]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (med - Mem$t[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + if (keepids) { + l = Memi[m[nh]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (Mem$t[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/icemask.x b/noao/twodspec/longslit/lscombine/src/icemask.x new file mode 100644 index 00000000..e60b8ab7 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icemask.x @@ -0,0 +1,114 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> + + +# IC_EMASK -- Create exposure mask. + +procedure ic_emask (pm, v, id, nimages, n, wts, npts) + +pointer pm #I Pixel mask +long v[ARB] #I Output vector +pointer id[nimages] #I Image id pointers +int nimages #I Number of images +int n[npts] #I Number of good pixels +real wts[npts] #I Weights +int npts #I Number of output pixels per line + +int i, j, k, impnli() +real exp +pointer buf + +pointer exps # Exposure times +pointer ev # IMIO coordinate vector +real ezero # Integer to real zero +real escale # Integer to real scale +int einit # Initialization flag +common /emask/ exps, ev, ezero, escale, einit + +begin + # Write scaling factors to the header. + if (einit == NO) { + if (ezero != 0. || escale != 1.) { + call imaddr (pm, "MASKZERO", ezero) + call imaddr (pm, "MASKSCAL", escale) + } + einit = YES + } + + call amovl (v, Meml[ev], IM_MAXDIM) + i = impnli (pm, buf, Meml[ev]) + call aclri (Memi[buf], npts) + do i = 1, npts { + exp = 0. + do j = 1, n[i] { + k = Memi[id[j]+i-1] + if (wts[k] > 0.) + exp = exp + Memr[exps+k-1] + } + Memi[buf] = nint((exp-ezero)/escale) + buf = buf + 1 + } +end + + +# IC_EINIT -- Initialize exposure mask. + +procedure ic_einit (in, nimages, key, default, maxval) + +int in[nimages] #I Image pointers +int nimages #I Number of images +char key[ARB] #I Exposure time keyword +real default #I Default exposure time +int maxval #I Maximum mask value + +int i +real exp, emin, emax, efrac, imgetr() + +pointer exps # Exposure times +pointer ev # IMIO coordinate vector +real ezero # Integer to real zero +real escale # Integer to real scale +int einit # Initialization flag +common /emask/ exps, ev, ezero, escale, einit + +begin + call malloc (ev, IM_MAXDIM, TY_LONG) + call malloc (exps, nimages, TY_REAL) + + emax = 0. + emin = MAX_REAL + efrac = 0 + do i = 1, nimages { + iferr (exp = imgetr (in[i], key)) + exp = default + exp = max (0., exp) + emax = emax + exp + if (exp > 0.) + emin = min (exp, emin) + efrac = max (abs(exp-nint(exp)), efrac) + Memr[exps+i-1] = exp + } + + # Set scaling. + ezero = 0. + escale = 1. + if (emin < 1.) { + escale = emin + emin = emin / escale + emax = emax / escale + } else if (emin == MAX_REAL) + emin = 0. + if (efrac > 0.001 && emax-emin < 1000.) { + escale = escale / 1000. + emin = emin * 1000. + emax = emax * 1000. + } + while (emax > maxval) { + escale = escale * 10. + emin = emin / 10. + emax = emax / 10. + } + einit = NO +end diff --git a/noao/twodspec/longslit/lscombine/src/icgdata.gx b/noao/twodspec/longslit/lscombine/src/icgdata.gx new file mode 100644 index 00000000..27f51ec5 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icgdata.gx @@ -0,0 +1,307 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include "../icombine.h" + +$for (sird) +# IC_GDATA -- Get line of image and mask data and apply threshold and scaling. +# Entirely empty lines are excluded. The data are compacted within the +# input data buffers. If it is required, the connection to the original +# image index is kept in the returned m data pointers. + +procedure ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, scales, + zeros, nimages, npts, v1, v2) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +pointer dbuf[nimages] # Data buffers +pointer d[nimages] # Data pointers +pointer id[nimages] # ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Empty mask flags +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +int nimages # Number of input images +int npts # NUmber of output points per line +long v1[ARB], v2[ARB] # Line vectors + +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, xt_imgnl$t() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnl$t + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (dbuf[i] == NULL) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = xt_imgnl$t (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnl$t (in[i], i, buf, v2, v1[2]) + call amov$t (Mem$t[buf+k-1], Mem$t[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Mem$t[dp] + if (a < lthresh || a > hthresh) { + Memi[m[i]+j-1] = 1 + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 1 + } + + # Check for completely empty lines + if (lflag[i] == D_MIX) { + lflag[i] = D_NONE + mp = m[i] + do j = 1, npts { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + a = Mem$t[dp] + if (a < lthresh || a > hthresh) { + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } + } + + # Apply scaling (avoiding masked pixels which might overflow?) + if (doscale) { + if (dflag == D_ALL) { + do i = 1, nimages { + dp = d[i] + a = scales[i] + b = -zeros[i] + do j = 1, npts { + Mem$t[dp] = Mem$t[dp] / a + b + dp = dp + 1 + } + } + } else if (dflag == D_MIX) { + do i = 1, nimages { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Mem$t[dp] = Mem$t[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) + Mem$t[dp] = Mem$t[dp] / a + b + dp = dp + 1 + mp = mp + 1 + } + } + } + } + } + + # Sort pointers to exclude unused images. + # Use the lflag array to keep track of the image index. + + if (dflag == D_ALL) + nused = nimages + else { + nused = 0 + do i = 1, nimages + if (lflag[i] != D_NONE) { + nused = nused + 1 + d[nused] = d[i] + m[nused] = m[i] + lflag[nused] = i + } + if (nused == 0) + dflag = D_NONE + } + + # Compact data to remove bad pixels + # Keep track of the image indices if needed + # If growing mark the end of the included image indices with zero + + if (dflag == D_ALL) { + call amovki (nused, n, npts) + if (keepids) + do i = 1, nimages + call amovki (i, Memi[id[i]], npts) + } else if (dflag == D_NONE) + call aclri (n, npts) + else { + call aclri (n, npts) + if (keepids) { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + Mem$t[d[k]+j-1] = Mem$t[dp] + Memi[id[k]+j-1] = l + } else + Memi[ip] = l + } + dp = dp + 1 + ip = ip + 1 + mp = mp + 1 + } + } + if (grow >= 1.) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) + Mem$t[d[k]+j-1] = Mem$t[dp] + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nimages, TY_PIXEL) + if (keepids) { + call malloc (ip, nimages, TY_INT) + call ic_2sort$t (d, Mem$t[dp], id, Memi[ip], n, npts) + call mfree (ip, TY_INT) + } else + call ic_sort$t (d, Mem$t[dp], n, npts) + call mfree (dp, TY_PIXEL) + } +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/icgrow.gx b/noao/twodspec/longslit/lscombine/src/icgrow.gx new file mode 100644 index 00000000..caf7dd29 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icgrow.gx @@ -0,0 +1,135 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <pmset.h> +include "../icombine.h" + +# IC_GROW -- Mark neigbors of rejected pixels. +# The rejected pixels (original plus grown) are saved in pixel masks. + +procedure ic_grow (out, v, m, n, buf, nimages, npts, pms) + +pointer out # Output image pointer +long v[ARB] # Output vector +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[npts,nimages] # Working buffer +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k, l, line, nl, rop, igrow, nset, ncompress, or() +real grow2, i2 +pointer mp, pm, pm_newmask() +errchk pm_newmask() + +include "../icombine.com" + +begin + if (dflag == D_NONE || grow == 0.) + return + + line = v[2] + nl = IM_LEN(out,2) + rop = or (PIX_SRC, PIX_DST) + + igrow = grow + grow2 = grow**2 + do l = 0, igrow { + i2 = grow2 - l * l + call aclri (buf, npts*nimages) + nset = 0 + do j = 1, npts { + do k = n[j]+1, nimages { + mp = Memi[m[k]+j-1] + if (mp == 0) + next + do i = 0, igrow { + if (i**2 > i2) + next + if (j > i) + buf[j-i,mp] = 1 + if (j+i <= npts) + buf[j+i,mp] = 1 + nset = nset + 1 + } + } + } + if (nset == 0) + return + + if (pms == NULL) { + call malloc (pms, nimages, TY_POINTER) + do i = 1, nimages + Memi[pms+i-1] = pm_newmask (out, 1) + ncompress = 0 + } + do i = 1, nimages { + pm = Memi[pms+i-1] + v[2] = line - l + if (v[2] > 0) + call pmplpi (pm, v, buf[1,i], 1, npts, rop) + if (l > 0) { + v[2] = line + l + if (v[2] <= nl) + call pmplpi (pm, v, buf[1,i], 1, npts, rop) + } + } + } + v[2] = line + + if (ncompress > 10) { + do i = 1, nimages { + pm = Memi[pms+i-1] + call pm_compress (pm) + } + ncompress = 0 + } else + ncompress = ncompress + 1 +end + + +$for (sird) +# IC_GROW$T -- Reject pixels. + +procedure ic_grow$t (v, d, m, n, buf, nimages, npts, pms) + +long v[ARB] # Output vector +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[ARB] # Buffer of npts +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k +pointer pm +bool pl_linenotempty() + +include "../icombine.com" + +begin + do k = 1, nimages { + pm = Memi[pms+k-1] + if (!pl_linenotempty (pm, v)) + next + call pmglpi (pm, v, buf, 1, npts, PIX_SRC) + do i = 1, npts { + if (buf[i] == 0) + next + for (j = 1; j <= n[i]; j = j + 1) { + if (Memi[m[j]+i-1] == k) { + if (j < n[i]) { + Mem$t[d[j]+i-1] = Mem$t[d[n[i]]+i-1] + Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] + } + n[i] = n[i] - 1 + dflag = D_MIX + break + } + } + } + } +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/icgscale.x b/noao/twodspec/longslit/lscombine/src/icgscale.x new file mode 100644 index 00000000..570697ad --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icgscale.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "icombine.h" + + +# IC_GSCALE -- Get scale values as directed by CL parameter. +# Only those values which are INDEF are changed. +# The values can be one of those in the dictionary, from a file specified +# with a @ prefix, or from an image header keyword specified by a ! prefix. + +int procedure ic_gscale (param, name, dic, in, exptime, values, nimages) + +char param[ARB] #I CL parameter name +char name[SZ_FNAME] #O Parameter value +char dic[ARB] #I Dictionary string +pointer in[nimages] #I IMIO pointers +real exptime[nimages] #I Exposure times +real values[nimages] #O Values +int nimages #I Number of images + +int type #O Type of value + +int fd, i, nowhite(), open(), fscan(), nscan(), strdic() +real rval, imgetr() +pointer errstr +errchk open, imgetr + +include "icombine.com" + +begin + call clgstr (param, name, SZ_FNAME) + if (nowhite (name, name, SZ_FNAME) == 0) + type = S_NONE + else if (name[1] == '@') { + type = S_FILE + do i = 1, nimages + if (IS_INDEFR(values[i])) + break + if (i <= nimages) { + fd = open (name[2], READ_ONLY, TEXT_FILE) + i = 0 + while (fscan (fd) != EOF) { + call gargr (rval) + if (nscan() != 1) + next + if (i == nimages) { + call eprintf ( + "Warning: Ignoring additional %s values in %s\n") + call pargstr (param) + call pargstr (name[2]) + break + } + i = i + 1 + if (IS_INDEFR(values[i])) + values[i] = rval + } + call close (fd) + if (i < nimages) { + call salloc (errstr, SZ_LINE, TY_CHAR) + call sprintf (errstr, SZ_FNAME, + "Insufficient %s values in %s") + call pargstr (param) + call pargstr (name[2]) + call error (1, errstr) + } + } + } else if (name[1] == '!') { + type = S_KEYWORD + do i = 1, nimages { + if (IS_INDEFR(values[i])) + values[i] = imgetr (in[i], name[2]) + if (project) { + call amovkr (values, values, nimages) + break + } + } + } else { + type = strdic (name, name, SZ_FNAME, dic) + if (type == 0) + call error (1, "Unknown scale, zero, or weight type") + if (type==S_EXPOSURE) + do i = 1, nimages + if (IS_INDEFR(values[i])) + values[i] = max (0.001, exptime[i]) + } + + return (type) +end diff --git a/noao/twodspec/longslit/lscombine/src/ichdr.x b/noao/twodspec/longslit/lscombine/src/ichdr.x new file mode 100644 index 00000000..2d19c5bd --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/ichdr.x @@ -0,0 +1,55 @@ +include <imset.h> + + +# IC_HDR -- Set output header. + +procedure ic_hdr (in, out, nimages) + +pointer in[nimages] #I Input images +pointer out[ARB] #I Output images +int nimages #I Number of images + +int i, imgnfn() +pointer sp, key, str, list, imofnlu() + +begin + call smark (sp) + call salloc (key, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Set new PROCID. + call xt_procid (out) + + # Set input PROCIDs. + if (nimages < 100) { + list = imofnlu (out, "PROCID[0-9][0-9]") + while (imgnfn (list, Memc[key], SZ_LINE) != EOF) + call imdelf (out, Memc[key]) + call imcfnl (list) + do i = 1, nimages { + call sprintf (Memc[key], 8, "PROCID%02d") + call pargi (i) + iferr (call imgstr (in[i], "PROCID", Memc[str], SZ_LINE)) { + iferr (call imgstr (in[i], "OBSID", Memc[str], SZ_LINE)) + Memc[str] = EOS + } + if (Memc[str] != EOS) + call imastr (out, Memc[key], Memc[str]) + } + + # Set input image names. + list = imofnlu (out, "IMCMB[0-9][0-9][0-9]") + while (imgnfn (list, Memc[key], SZ_LINE) != EOF) + call imdelf (out, Memc[key]) + call imcfnl (list) + do i = 1, nimages { + iferr (call imgstr (in[i], "ICFNAME", Memc[str], SZ_LINE)) + call imstats (in[i], IM_IMAGENAME, Memc[str], SZ_LINE) + call sprintf (Memc[key], SZ_LINE, "IMCMB%03d") + call pargi (i) + call imastr (out, Memc[key], Memc[str]) + } + } + + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lscombine/src/icimstack.x b/noao/twodspec/longslit/lscombine/src/icimstack.x new file mode 100644 index 00000000..d5628694 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icimstack.x @@ -0,0 +1,186 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> + + +# IC_IMSTACK -- Stack images into a single image of higher dimension. + +procedure ic_imstack (list, output, mask) + +int list #I List of images +char output[ARB] #I Name of output image +char mask[ARB] #I Name of output mask + +int i, j, npix +long line_in[IM_MAXDIM], line_out[IM_MAXDIM], line_outbpm[IM_MAXDIM] +pointer sp, input, bpmname, key, in, out, inbpm, outbpm, buf_in, buf_out, ptr + +int imtgetim(), imtlen(), errget() +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +pointer immap(), pm_newmask() +errchk immap +errchk imgnls, imgnli, imgnll, imgnlr, imgnld, imgnlx +errchk impnls, impnli, impnll, impnlr, impnld, impnlx + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (bpmname, SZ_FNAME, TY_CHAR) + call salloc (key, SZ_FNAME, TY_CHAR) + + iferr { + # Add each input image to the output image. + out = NULL; outbpm = NULL + i = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + + i = i + 1 + in = NULL; inbpm = NULL + ptr = immap (Memc[input], READ_ONLY, 0) + in = ptr + + # For the first input image map the output image as a copy + # and increment the dimension. Set the output line counter. + + if (i == 1) { + ptr = immap (output, NEW_COPY, in) + out = ptr + IM_NDIM(out) = IM_NDIM(out) + 1 + IM_LEN(out, IM_NDIM(out)) = imtlen (list) + npix = IM_LEN(out, 1) + call amovkl (long(1), line_out, IM_MAXDIM) + + if (mask[1] != EOS) { + ptr = immap (mask, NEW_COPY, in) + outbpm = ptr + IM_NDIM(outbpm) = IM_NDIM(outbpm) + 1 + IM_LEN(outbpm, IM_NDIM(outbpm)) = imtlen (list) + call amovkl (long(1), line_outbpm, IM_MAXDIM) + } + } + + # Check next input image for consistency with the output image. + if (IM_NDIM(in) != IM_NDIM(out) - 1) + call error (0, "Input images not consistent") + do j = 1, IM_NDIM(in) { + if (IM_LEN(in, j) != IM_LEN(out, j)) + call error (0, "Input images not consistent") + } + + call sprintf (Memc[key], SZ_FNAME, "stck%04d") + call pargi (i) + call imastr (out, Memc[key], Memc[input]) + + # Copy the input lines from the image to the next lines of + # the output image. Switch on the output data type to optimize + # IMIO. + + call amovkl (long(1), line_in, IM_MAXDIM) + switch (IM_PIXTYPE (out)) { + case TY_SHORT: + while (imgnls (in, buf_in, line_in) != EOF) { + if (impnls (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovs (Mems[buf_in], Mems[buf_out], npix) + } + case TY_INT: + while (imgnli (in, buf_in, line_in) != EOF) { + if (impnli (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovi (Memi[buf_in], Memi[buf_out], npix) + } + case TY_USHORT, TY_LONG: + while (imgnll (in, buf_in, line_in) != EOF) { + if (impnll (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovl (Meml[buf_in], Meml[buf_out], npix) + } + case TY_REAL: + while (imgnlr (in, buf_in, line_in) != EOF) { + if (impnlr (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovr (Memr[buf_in], Memr[buf_out], npix) + } + case TY_DOUBLE: + while (imgnld (in, buf_in, line_in) != EOF) { + if (impnld (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovd (Memd[buf_in], Memd[buf_out], npix) + } + case TY_COMPLEX: + while (imgnlx (in, buf_in, line_in) != EOF) { + if (impnlx (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovx (Memx[buf_in], Memx[buf_out], npix) + } + default: + while (imgnlr (in, buf_in, line_in) != EOF) { + if (impnlr (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovr (Memr[buf_in], Memr[buf_out], npix) + } + } + + # Copy mask. + if (mask[1] != EOS) { + iferr (call imgstr (in, "bpm", Memc[bpmname], SZ_FNAME)) { + Memc[bpmname] = EOS + ptr = pm_newmask (in, 27) + } else + ptr = immap (Memc[bpmname], READ_ONLY, 0) + inbpm = ptr + + if (IM_NDIM(inbpm) != IM_NDIM(outbpm) - 1) + call error (0, "Input images not consistent") + do j = 1, IM_NDIM(inbpm) { + if (IM_LEN(inbpm, j) != IM_LEN(outbpm, j)) + call error (0, "Masks not consistent") + } + + call amovkl (long(1), line_in, IM_MAXDIM) + while (imgnli (inbpm, buf_in, line_in) != EOF) { + if (impnli (outbpm, buf_out, line_outbpm) == EOF) + call error (0, "Error writing output mask") + call amovi (Memi[buf_in], Memi[buf_out], npix) + } + + call sprintf (Memc[key], SZ_FNAME, "bpm%04d") + call pargi (i) + call imastr (out, Memc[key], Memc[bpmname]) + + call imunmap (inbpm) + } + + call imunmap (in) + } + } then { + i = errget (Memc[key], SZ_FNAME) + call erract (EA_WARN) + if (outbpm != NULL) { + call imunmap (outbpm) + iferr (call imdelete (mask)) + ; + } + if (out != NULL) { + call imunmap (out) + iferr (call imdelete (output)) + ; + } + if (inbpm != NULL) + call imunmap (inbpm) + if (in != NULL) + call imunmap (in) + call sfree (sp) + call error (i, "Can't make temporary stack images") + } + + # Finish up. + if (outbpm != NULL) { + call imunmap (outbpm) + call imastr (out, "bpm", mask) + } + call imunmap (out) + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lscombine/src/iclog.x b/noao/twodspec/longslit/lscombine/src/iclog.x new file mode 100644 index 00000000..43ab37ab --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/iclog.x @@ -0,0 +1,422 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <mach.h> +include "icombine.h" +include "icmask.h" + +# IC_LOG -- Output log information is a log file has been specfied. + +procedure ic_log (in, out, ncombine, exptime, sname, zname, wname, + mode, median, mean, scales, zeros, wts, offsets, nimages, + dozero, nout) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int ncombine[nimages] # Number of previous combined images +real exptime[nimages] # Exposure times +char sname[ARB] # Scale name +char zname[ARB] # Zero name +char wname[ARB] # Weight name +real mode[nimages] # Modes +real median[nimages] # Medians +real mean[nimages] # Means +real scales[nimages] # Scale factors +real zeros[nimages] # Zero or sky levels +real wts[nimages] # Weights +int offsets[nimages,ARB] # Image offsets +int nimages # Number of images +bool dozero # Zero flag +int nout # Number of images combined in output + +int i, j, stack, ctor() +real rval, imgetr() +long clktime() +bool prncombine, prexptime, prmode, prmedian, prmean, prmask +bool prrdn, prgain, prsn +pointer sp, fname, bpname, key +errchk imgetr + +include "icombine.com" + +begin + if (logfd == NULL) + return + + call smark (sp) + call salloc (fname, SZ_LINE, TY_CHAR) + call salloc (bpname, SZ_LINE, TY_CHAR) + + stack = NO + if (project) { + ifnoerr (call imgstr (in[1], "stck0001", Memc[fname], SZ_LINE)) + stack = YES + } + if (stack == YES) + call salloc (key, SZ_FNAME, TY_CHAR) + + # Time stamp the log and print parameter information. + + call cnvdate (clktime(0), Memc[fname], SZ_LINE) + call fprintf (logfd, "\n%s: %s\n") + call pargstr (Memc[fname]) + if (ictask != NULL) + call pargstr (Memc[ictask]) + else + call pargstr ("IMCOMBINE") + switch (combine) { + case AVERAGE: + call fprintf (logfd, " combine = average, ") + case MEDIAN: + call fprintf (logfd, " combine = median, ") + case SUM: + call fprintf (logfd, " combine = sum, ") + } + call fprintf (logfd, "scale = %s, zero = %s, weight = %s\n") + call pargstr (sname) + call pargstr (zname) + call pargstr (wname) + + switch (reject) { + case MINMAX: + call fprintf (logfd, " reject = minmax, nlow = %d, nhigh = %d\n") + call pargi (nint (flow * nimages)) + call pargi (nint (fhigh * nimages)) + case CCDCLIP: + call fprintf (logfd, " reject = ccdclip, mclip = %b, nkeep = %d\n") + call pargb (mclip) + call pargi (nkeep) + call fprintf (logfd, + " rdnoise = %s, gain = %s, snoise = %s, sigma = %g, hsigma = %g\n") + call pargstr (Memc[rdnoise]) + call pargstr (Memc[gain]) + call pargstr (Memc[snoise]) + call pargr (lsigma) + call pargr (hsigma) + case CRREJECT: + call fprintf (logfd, + " reject = crreject, mclip = %b, nkeep = %d\n") + call pargb (mclip) + call pargi (nkeep) + call fprintf (logfd, + " rdnoise = %s, gain = %s, snoise = %s, hsigma = %g\n") + call pargstr (Memc[rdnoise]) + call pargstr (Memc[gain]) + call pargstr (Memc[snoise]) + call pargr (hsigma) + case PCLIP: + call fprintf (logfd, " reject = pclip, nkeep = %d\n") + call pargi (nkeep) + call fprintf (logfd, " pclip = %g, lsigma = %g, hsigma = %g\n") + call pargr (pclip) + call pargr (lsigma) + call pargr (hsigma) + case SIGCLIP: + call fprintf (logfd, " reject = sigclip, mclip = %b, nkeep = %d\n") + call pargb (mclip) + call pargi (nkeep) + call fprintf (logfd, " lsigma = %g, hsigma = %g\n") + call pargr (lsigma) + call pargr (hsigma) + case AVSIGCLIP: + call fprintf (logfd, + " reject = avsigclip, mclip = %b, nkeep = %d\n") + call pargb (mclip) + call pargi (nkeep) + call fprintf (logfd, " lsigma = %g, hsigma = %g\n") + call pargr (lsigma) + call pargr (hsigma) + } + if (reject != NONE && grow >= 1.) { + call fprintf (logfd, " grow = %g\n") + call pargr (grow) + } + if (dothresh) { + if (lthresh > -MAX_REAL && hthresh < MAX_REAL) { + call fprintf (logfd, " lthreshold = %g, hthreshold = %g\n") + call pargr (lthresh) + call pargr (hthresh) + } else if (lthresh > -MAX_REAL) { + call fprintf (logfd, " lthreshold = %g\n") + call pargr (lthresh) + } else { + call fprintf (logfd, " hthreshold = %g\n") + call pargr (hthresh) + } + } + call fprintf (logfd, " blank = %g\n") + call pargr (blank) + if (Memc[statsec] != EOS) { + call fprintf (logfd, " statsec = %s\n") + call pargstr (Memc[fname]) + } + + if (ICM_TYPE(icm) != M_NONE) { + switch (ICM_TYPE(icm)) { + case M_BOOLEAN, M_GOODVAL: + call fprintf (logfd, " masktype = goodval, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_BADVAL: + call fprintf (logfd, " masktype = badval, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_GOODBITS: + call fprintf (logfd, " masktype = goodbits, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_BADBITS: + call fprintf (logfd, " masktype = badbits, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + } + } + + # Print information pertaining to individual images as a set of + # columns with the image name being the first column. Determine + # what information is relevant and print the appropriate header. + + prncombine = false + prexptime = false + prmode = false + prmedian = false + prmean = false + prmask = false + prrdn = false + prgain = false + prsn = false + do i = 1, nimages { + if (ncombine[i] != ncombine[1]) + prncombine = true + if (exptime[i] != exptime[1]) + prexptime = true + if (mode[i] != mode[1]) + prmode = true + if (median[i] != median[1]) + prmedian = true + if (mean[i] != mean[1]) + prmean = true + if (ICM_TYPE(icm) != M_NONE) { + if (project) + bpname = Memi[ICM_LOGNAMES(icm)] + else + bpname = Memi[ICM_LOGNAMES(icm)+i-1] + if (Memc[bpname] != EOS) + prmask = true + } + if (reject == CCDCLIP || reject == CRREJECT) { + j = 1 + if (ctor (Memc[rdnoise], j, rval) == 0) + prrdn = true + j = 1 + if (ctor (Memc[gain], j, rval) == 0) + prgain = true + j = 1 + if (ctor (Memc[snoise], j, rval) == 0) + prsn = true + } + } + + call fprintf (logfd, " %20s ") + call pargstr ("Images") + if (prncombine) { + call fprintf (logfd, " %6s") + call pargstr ("N") + } + if (prexptime) { + call fprintf (logfd, " %6s") + call pargstr ("Exp") + } + if (prmode) { + call fprintf (logfd, " %7s") + call pargstr ("Mode") + } + if (prmedian) { + call fprintf (logfd, " %7s") + call pargstr ("Median") + } + if (prmean) { + call fprintf (logfd, " %7s") + call pargstr ("Mean") + } + if (prrdn) { + call fprintf (logfd, " %7s") + call pargstr ("Rdnoise") + } + if (prgain) { + call fprintf (logfd, " %6s") + call pargstr ("Gain") + } + if (prsn) { + call fprintf (logfd, " %6s") + call pargstr ("Snoise") + } + if (doscale) { + call fprintf (logfd, " %6s") + call pargstr ("Scale") + } + if (dozero) { + call fprintf (logfd, " %7s") + call pargstr ("Zero") + } + if (dowts) { + call fprintf (logfd, " %6s") + call pargstr ("Weight") + } + if (!aligned) { + call fprintf (logfd, " %9s") + call pargstr ("Offsets") + } + if (prmask) { + call fprintf (logfd, " %s") + call pargstr ("Maskfile") + } + call fprintf (logfd, "\n") + + do i = 1, nimages { + if (stack == YES) { + call sprintf (Memc[key], SZ_FNAME, "stck%04d") + call pargi (i) + ifnoerr (call imgstr (in[i], Memc[key], Memc[fname], SZ_LINE)) { + call fprintf (logfd, " %21s") + call pargstr (Memc[fname]) + } else { + call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " %16s[%3d]") + call pargstr (Memc[fname]) + call pargi (i) + } + } else if (project) { + call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " %16s[%3d]") + call pargstr (Memc[fname]) + call pargi (i) + } else ifnoerr (call imgstr (in[i],"ICFNAME",Memc[fname],SZ_LINE)) { + call fprintf (logfd, " %21s") + call pargstr (Memc[fname]) + } else { + call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " %21s") + call pargstr (Memc[fname]) + } + if (prncombine) { + call fprintf (logfd, " %6d") + call pargi (ncombine[i]) + } + if (prexptime) { + call fprintf (logfd, " %6.1f") + call pargr (exptime[i]) + } + if (prmode) { + call fprintf (logfd, " %7.5g") + call pargr (mode[i]) + } + if (prmedian) { + call fprintf (logfd, " %7.5g") + call pargr (median[i]) + } + if (prmean) { + call fprintf (logfd, " %7.5g") + call pargr (mean[i]) + } + if (prrdn) { + rval = imgetr (in[i], Memc[rdnoise]) + call fprintf (logfd, " %7g") + call pargr (rval) + } + if (prgain) { + rval = imgetr (in[i], Memc[gain]) + call fprintf (logfd, " %6g") + call pargr (rval) + } + if (prsn) { + rval = imgetr (in[i], Memc[snoise]) + call fprintf (logfd, " %6g") + call pargr (rval) + } + if (doscale) { + call fprintf (logfd, " %6.3f") + call pargr (1./scales[i]) + } + if (dozero) { + call fprintf (logfd, " %7.5g") + call pargr (-zeros[i]) + } + if (dowts) { + call fprintf (logfd, " %6.3f") + call pargr (wts[i]) + } + if (!aligned) { + if (IM_NDIM(out[1]) == 1) { + call fprintf (logfd, " %9d") + call pargi (offsets[i,1]) + } else { + do j = 1, IM_NDIM(out[1]) { + call fprintf (logfd, " %4d") + call pargi (offsets[i,j]) + } + } + } + if (prmask) { + if (stack == YES) { + call sprintf (Memc[key], SZ_FNAME, "bpm%04d") + call pargi (i) + ifnoerr (call imgstr (in[i], Memc[key], Memc[fname], + SZ_LINE)) { + call fprintf (logfd, " %s") + call pargstr (Memc[fname]) + } else { + call fprintf (logfd, " %s") + call pargstr (Memc[bpname]) + } + } else if (ICM_TYPE(icm) != M_NONE) { + if (project) + bpname = Memi[ICM_LOGNAMES(icm)] + else + bpname = Memi[ICM_LOGNAMES(icm)+i-1] + if (Memc[bpname] != EOS) { + call fprintf (logfd, " %s") + call pargstr (Memc[bpname]) + } + } + } + call fprintf (logfd, "\n") + } + + # Log information about the output images. + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, "\n Output image = %s, ncombine = %d") + call pargstr (Memc[fname]) + call pargi (nout) + call fprintf (logfd, "\n") + + if (out[2] != NULL) { + call imstats (out[2], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Bad pixel mask = %s\n") + call pargstr (Memc[fname]) + } + + if (out[4] != NULL) { + call imstats (out[4], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Rejection mask = %s\n") + call pargstr (Memc[fname]) + } + + if (out[5] != NULL) { + call imstats (out[5], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Number rejected mask = %s\n") + call pargstr (Memc[fname]) + } + + if (out[6] != NULL) { + call imstats (out[6], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Exposure mask = %s\n") + call pargstr (Memc[fname]) + } + + if (out[3] != NULL) { + call imstats (out[3], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Sigma image = %s\n") + call pargstr (Memc[fname]) + } + + call flush (logfd) + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lscombine/src/icmask.com b/noao/twodspec/longslit/lscombine/src/icmask.com new file mode 100644 index 00000000..baba6f6a --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icmask.com @@ -0,0 +1,8 @@ +# IMCMASK -- Common for IMCOMBINE mask interface. + +int mtype # Mask type +int mvalue # Mask value +pointer bufs # Pointer to data line buffers +pointer pms # Pointer to array of PMIO pointers + +common /imcmask/ mtype, mvalue, bufs, pms diff --git a/noao/twodspec/longslit/lscombine/src/icmask.h b/noao/twodspec/longslit/lscombine/src/icmask.h new file mode 100644 index 00000000..533c601d --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icmask.h @@ -0,0 +1,9 @@ +# ICMASK -- Data structure for IMCOMBINE mask interface. + +define ICM_LEN 6 # Structure length +define ICM_TYPE Memi[$1] # Mask type +define ICM_VALUE Memi[$1+1] # Mask value +define ICM_BUFS Memi[$1+2] # Pointer to data line buffers +define ICM_PMS Memi[$1+3] # Pointer to array of PMIO pointers +define ICM_NAMES Memi[$1+4] # Pointer to array of mask names +define ICM_LOGNAMES Memi[$1+5] # Pointer to array of mask log names diff --git a/noao/twodspec/longslit/lscombine/src/icmask.x b/noao/twodspec/longslit/lscombine/src/icmask.x new file mode 100644 index 00000000..9242405d --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icmask.x @@ -0,0 +1,499 @@ +include <imhdr.h> +include <pmset.h> +include "icombine.h" +include "icmask.h" + +# IC_MASK -- ICOMBINE mask interface +# +# IC_MOPEN -- Initialize mask interface +# IC_MCLOSE -- Close the mask interface +# IC_MGET -- Get lines of mask pixels for all the images +# IC_MGET1 -- Get a line of mask pixels for the specified image +# IC_MCLOSE1-- Close a mask for the specified image index + + +# IC_MOPEN -- Initialize mask interface. + +procedure ic_mopen (in, out, nimages, offsets) + +pointer in[nimages] #I Input images +pointer out[ARB] #I Output images +int nimages #I Number of images +int offsets[nimages,ARB] #I Offsets to output image + +int mtype # Mask type +int mvalue # Mask value +pointer bufs # Pointer to data line buffers +pointer pms # Pointer to array of PMIO pointers +pointer names # Pointer to array of string pointers +pointer lognames # Pointer to array of string pointers + +int i, j, k, nin, nout, npix, npms, nowhite(), strdic() +int clgeti() +pointer sp, key, fname, logname, title, pm, pm_open() +bool invert, pm_empty() +errchk calloc, pm_open, pm_loadf, pm_loadim + +include "icombine.com" + +begin + icm = NULL + if (IM_NDIM(out[1]) == 0) + return + + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (title, SZ_FNAME, TY_CHAR) + + # Determine the mask parameters and allocate memory. + # The mask buffers are initialize to all excluded so that + # output points outside the input data are always excluded + # and don't need to be set on a line-by-line basis. + + mtype = M_NONE + call clgstr ("masktype", Memc[key], SZ_FNAME) + if (nowhite (Memc[key], Memc[key], SZ_FNAME) > 0) { + if (Memc[key] == '!') { + mtype = M_GOODVAL + call strcpy (Memc[key+1], Memc[key], SZ_FNAME) + } else { + mtype = strdic (Memc[key], Memc[title], SZ_FNAME, MASKTYPES) + if (mtype == 0) { + call sprintf (Memc[title], SZ_FNAME, + "Invalid or ambiguous masktype (%s)") + call pargstr (Memc[key]) + call error (1, Memc[title]) + } + call strcpy ("BPM", Memc[key], SZ_FNAME) + } + } + mvalue = clgeti ("maskvalue") + npix = IM_LEN(out[1],1) + call calloc (pms, nimages, TY_POINTER) + call calloc (bufs, nimages, TY_POINTER) + call calloc (names, nimages, TY_POINTER) + call calloc (lognames, nimages, TY_POINTER) + do i = 1, nimages { + call malloc (Memi[bufs+i-1], npix, TY_INT) + call amovki (1, Memi[Memi[bufs+i-1]], npix) + } + + # Check for special cases. The BOOLEAN type is used when only + # zero and nonzero are significant; i.e. the actual mask values are + # not important. The invert flag is used to indicate that + # empty masks are all bad rather the all good. + + if (mtype == 0) + mtype = M_NONE + if (mtype == M_BADBITS && mvalue == 0) + mtype = M_NONE + if (mvalue == 0 && (mtype == M_GOODVAL || mtype == M_GOODBITS)) + mtype = M_BOOLEAN + if ((mtype == M_BADVAL && mvalue == 0) || + (mtype == M_GOODVAL && mvalue != 0) || + (mtype == M_GOODBITS && mvalue == 0)) + invert = true + else + invert = false + + # If mask images are to be used, get the mask name from the image + # header and open it saving the descriptor in the pms array. + # Empty masks (all good) are treated as if there was no mask image. + + nout = IM_LEN(out[1],1) + npms = 0 + do i = 1, nimages { + if (mtype != M_NONE) { + call malloc (Memi[names+i-1], SZ_FNAME, TY_CHAR) + call malloc (Memi[lognames+i-1], SZ_FNAME, TY_CHAR) + fname = Memi[names+i-1] + logname = Memi[lognames+i-1] + ifnoerr (call imgstr (in[i],Memc[key],Memc[fname],SZ_FNAME)) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + Memc[fname] = EOS + else { + pm = pm_open (NULL) + iferr (call pm_loadf (pm, Memc[fname], Memc[title], + SZ_FNAME)) + call pm_loadim (pm, Memc[fname], Memc[title], + SZ_FNAME) + call pm_seti (pm, P_REFIM, in[i]) + if (pm_empty (pm) && !invert) + Memc[fname] = EOS + else { + if (project) + npms = nimages + else + npms = npms + 1 + } + call pm_close (pm) + + ifnoerr (call imgstr (in[i], "ICBPM", Memc[title], + SZ_FNAME)) + call strcpy (Memc[title], Memc[logname], SZ_FNAME) + else + call strcpy (Memc[fname], Memc[logname], SZ_FNAME) + } + if (project) + break + } else { + Memc[fname] = EOS + Memc[logname] = EOS + } + } + } + + # If no mask images are found and the mask parameters imply that + # good values are 0 then use the special case of no masks. + + if (npms == 0) { + if (!invert) + mtype = M_NONE + } + + # Set up mask structure. + call calloc (icm, ICM_LEN, TY_STRUCT) + ICM_TYPE(icm) = mtype + ICM_VALUE(icm) = mvalue + ICM_BUFS(icm) = bufs + ICM_PMS(icm) = pms + ICM_NAMES(icm) = names + ICM_LOGNAMES(icm) = lognames + + call sfree (sp) +end + + +# IC_MCLOSE -- Close the mask interface. + +procedure ic_mclose (nimages) + +int nimages # Number of images + +int i +include "icombine.com" + +begin + if (icm == NULL) + return + + do i = 1, nimages { + call mfree (Memi[ICM_NAMES(icm)+i-1], TY_CHAR) + call mfree (Memi[ICM_BUFS(icm)+i-1], TY_INT) + } + do i = 1, nimages { + if (Memi[ICM_PMS(icm)+i-1] != NULL) + call pm_close (Memi[ICM_PMS(icm)+i-1]) + if (project) + break + } + call mfree (ICM_NAMES(icm), TY_POINTER) + call mfree (ICM_BUFS(icm), TY_POINTER) + call mfree (ICM_PMS(icm), TY_POINTER) + call mfree (icm, TY_STRUCT) +end + + +# IC_MGET -- Get lines of mask pixels in the output coordinate system. +# This converts the mask format to an array where zero is good and nonzero +# is bad. This has special cases for optimization. + +procedure ic_mget (in, out, offsets, v1, v2, m, lflag, nimages) + +pointer in[nimages] # Input image pointers +pointer out[ARB] # Output image pointer +int offsets[nimages,ARB] # Offsets to output image +long v1[IM_MAXDIM] # Data vector desired in output image +long v2[IM_MAXDIM] # Data vector in input image +pointer m[nimages] # Pointer to mask pointers +int lflag[nimages] # Line flags +int nimages # Number of images + +int mtype # Mask type +int mvalue # Mask value +pointer bufs # Pointer to data line buffers +pointer pms # Pointer to array of PMIO pointers + +char title[1] +int i, j, k, ndim, nin, nout, npix +pointer buf, pm, names, fname, pm_open() +bool pm_linenotempty() +errchk pm_glpi, pm_open, pm_loadf, pm_loadim + +include "icombine.com" + +begin + # Determine if masks are needed at all. Note that the threshold + # is applied by simulating mask values so the mask pointers have to + # be set. + + dflag = D_ALL + if (icm == NULL) + return + if (ICM_TYPE(icm) == M_NONE && aligned && !dothresh) + return + + mtype = ICM_TYPE(icm) + mvalue = ICM_VALUE(icm) + bufs = ICM_BUFS(icm) + pms = ICM_PMS(icm) + names = ICM_NAMES(icm) + + # Set the mask pointers and line flags and apply offsets if needed. + + ndim = IM_NDIM(out[1]) + nout = IM_LEN(out[1],1) + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + + m[i] = Memi[bufs+i-1] + buf = Memi[bufs+i-1] + j + if (project) { + pm = Memi[pms] + fname = Memi[names] + } else { + pm = Memi[pms+i-1] + fname = Memi[names+i-1] + } + + if (npix < 1) + lflag[i] = D_NONE + else if (npix == nout) + lflag[i] = D_ALL + else + lflag[i] = D_MIX + + if (lflag[i] != D_NONE) { + v2[1] = 1 + j - offsets[i,1] + do j = 2, ndim { + v2[j] = v1[j] - offsets[i,j] + if (v2[j] < 1 || v2[j] > IM_LEN(in[i],j)) { + lflag[i] = D_NONE + break + } + } + } + if (project) + v2[ndim+1] = i + + if (lflag[i] == D_NONE) { + if (pm != NULL && !project) { + call pm_close (pm) + Memi[pms+i-1] = NULL + } + next + } + + if (fname == NULL) { + call aclri (Memi[buf], npix) + next + } else if (Memc[fname] == EOS) { + call aclri (Memi[buf], npix) + next + } + + # Do mask I/O and convert to appropriate values in order of + # expected usage. + + if (pm == NULL) { + pm = pm_open (NULL) + iferr (call pm_loadf (pm, Memc[fname], title, 1)) + call pm_loadim (pm, Memc[fname], title, 1) + call pm_seti (pm, P_REFIM, in[i]) + if (project) + Memi[pms] = pm + else + Memi[pms+i-1] = pm + } + + if (pm_linenotempty (pm, v2)) { + call pm_glpi (pm, v2, Memi[buf], 32, npix, 0) + + if (mtype == M_BOOLEAN) + ; + else if (mtype == M_BADBITS) + call aandki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_BADVAL) + call abeqki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_GOODBITS) { + call aandki (Memi[buf], mvalue, Memi[buf], npix) + call abeqki (Memi[buf], 0, Memi[buf], npix) + } else if (mtype == M_GOODVAL) + call abneki (Memi[buf], mvalue, Memi[buf], npix) + + lflag[i] = D_NONE + do j = 1, npix + if (Memi[buf+j-1] == 0) { + lflag[i] = D_MIX + break + } + } else { + if (mtype == M_BOOLEAN || mtype == M_BADBITS) { + call aclri (Memi[buf], npix) + } else if ((mtype == M_BADVAL && mvalue != 0) || + (mtype == M_GOODVAL && mvalue == 0)) { + call aclri (Memi[buf], npix) + } else { + call amovki (1, Memi[buf], npix) + lflag[i] = D_NONE + } + } + } + + # Set overall data flag + dflag = lflag[1] + do i = 2, nimages { + if (lflag[i] != dflag) { + dflag = D_MIX + break + } + } +end + + +# IC_MGET1 -- Get line of mask pixels from a specified image. +# This is used by the IC_STAT procedure. This procedure converts the +# stored mask format to an array where zero is good and nonzero is bad. +# The data vector and returned mask array are in the input image pixel system. + +procedure ic_mget1 (in, image, nimages, offset, v, m) + +pointer in # Input image pointer +int image # Image index +int nimages # Number of images +int offset # Column offset +long v[IM_MAXDIM] # Data vector desired +pointer m # Pointer to mask + +int mtype # Mask type +int mvalue # Mask value +pointer bufs # Pointer to data line buffers +pointer pms # Pointer to array of PMIO pointers + +char title[1] +int i, npix +pointer buf, pm, names, fname, pm_open() +bool pm_linenotempty() +errchk pm_glpi, pm_open, pm_loadf, pm_loadim + +include "icombine.com" + +begin + dflag = D_ALL + if (icm == NULL) + return + if (ICM_TYPE(icm) == M_NONE) + return + + mtype = ICM_TYPE(icm) + mvalue = ICM_VALUE(icm) + bufs = ICM_BUFS(icm) + pms = ICM_PMS(icm) + names = ICM_NAMES(icm) + + npix = IM_LEN(in,1) + m = Memi[bufs+image-1] + offset + if (project) { + pm = Memi[pms] + fname = Memi[names] + } else { + pm = Memi[pms+image-1] + fname = Memi[names+image-1] + } + + if (fname == NULL) + return + if (Memc[fname] == EOS) + return + + if (pm == NULL) { + pm = pm_open (NULL) + iferr (call pm_loadf (pm, Memc[fname], title, 1)) + call pm_loadim (pm, Memc[fname], title, 1) + call pm_seti (pm, P_REFIM, in) + if (project) + Memi[pms] = pm + else + Memi[pms+image-1] = pm + } + + # Do mask I/O and convert to appropriate values in order of + # expected usage. + + buf = m + if (pm_linenotempty (pm, v)) { + call pm_glpi (pm, v, Memi[buf], 32, npix, 0) + + if (mtype == M_BOOLEAN) + ; + else if (mtype == M_BADBITS) + call aandki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_BADVAL) + call abeqki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_GOODBITS) { + call aandki (Memi[buf], mvalue, Memi[buf], npix) + call abeqki (Memi[buf], 0, Memi[buf], npix) + } else if (mtype == M_GOODVAL) + call abneki (Memi[buf], mvalue, Memi[buf], npix) + + dflag = D_NONE + do i = 1, npix + if (Memi[buf+i-1] == 0) { + dflag = D_MIX + break + } + } else { + if (mtype == M_BOOLEAN || mtype == M_BADBITS) { + ; + } else if ((mtype == M_BADVAL && mvalue != 0) || + (mtype == M_GOODVAL && mvalue == 0)) { + ; + } else + dflag = D_NONE + } +end + + +# IC_MCLOSE1 -- Close mask by index. + +procedure ic_mclose1 (image, nimages) + +int image # Image index +int nimages # Number of images + +pointer pms, names, pm, fname +include "icombine.com" + +begin + if (icm == NULL) + return + + pms = ICM_PMS(icm) + names = ICM_NAMES(icm) + + if (project) { + pm = Memi[pms] + fname = Memi[names] + } else { + pm = Memi[pms+image-1] + fname = Memi[names+image-1] + } + + if (fname == NULL || pm == NULL) + return + if (Memc[fname] == EOS || pm == NULL) + return + + call pm_close (pm) + if (project) + Memi[pms] = NULL + else + Memi[pms+image-1] = NULL +end diff --git a/noao/twodspec/longslit/lscombine/src/icmedian.gx b/noao/twodspec/longslit/lscombine/src/icmedian.gx new file mode 100644 index 00000000..4ac51ae6 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icmedian.gx @@ -0,0 +1,231 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +$for (sird) +# IC_MEDIAN -- Median of lines + +procedure ic_median$t (d, n, npts, doblank, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +int doblank # Set blank values? +$if (datatype == sil) +real median[npts] # Median +$else +PIXEL median[npts] # Median +$endif + +int i, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +$if (datatype == silx) +real val1, val2, val3 +$else +PIXEL val1, val2, val3 +$endif +PIXEL temp, wtemp +$if (datatype == x) +real abs_temp +$endif + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + even = (mod (n1, 2) == 0) + j1 = n1 / 2 + 1 + j2 = n1 / 2 + do i = 1, npts { + k = i - 1 + if (even) { + val1 = Mem$t[d[j1]+k] + val2 = Mem$t[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Mem$t[d[j1]+k] + } + } else { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod (n1, 2) == 0) { + j2 = n1 / 2 + val1 = Mem$t[d[j1]+k] + val2 = Mem$t[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Mem$t[d[j1]+k] + } else if (doblank == YES) + median[i] = blank + } + } + return + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = n[i] + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mem$t[d[j]+k]; lo1 = lo; up1 = up + $if (datatype == x) + abs_temp = abs (temp) + $endif + + repeat { + $if (datatype == x) + while (abs (Mem$t[d[lo1]+k]) < abs_temp) + $else + while (Mem$t[d[lo1]+k] < temp) + $endif + lo1 = lo1 + 1 + $if (datatype == x) + while (abs_temp < abs (Mem$t[d[up1]+k])) + $else + while (temp < Mem$t[d[up1]+k]) + $endif + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mem$t[d[lo1]+k] + Mem$t[d[lo1]+k] = Mem$t[d[up1]+k] + Mem$t[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Mem$t[d[j]+k] + + if (mod (n1,2) == 0) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mem$t[d[j]+k]; lo1 = lo; up1 = up + $if (datatype == x) + abs_temp = abs (temp) + $endif + + repeat { + $if (datatype == x) + while (abs (Mem$t[d[lo1]+k]) < abs_temp) + $else + while (Mem$t[d[lo1]+k] < temp) + $endif + lo1 = lo1 + 1 + $if (datatype == x) + while (abs_temp < abs (Mem$t[d[up1]+k])) + $else + while (temp < Mem$t[d[up1]+k]) + $endif + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mem$t[d[lo1]+k] + Mem$t[d[lo1]+k] = Mem$t[d[up1]+k] + Mem$t[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Mem$t[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else if (n1 == 3) { + $if (datatype == x) + val1 = abs (Mem$t[d[1]+k]) + val2 = abs (Mem$t[d[2]+k]) + val3 = abs (Mem$t[d[3]+k]) + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = Mem$t[d[2]+k] + else if (val1 < val3) # acb + median[i] = Mem$t[d[3]+k] + else # cab + median[i] = Mem$t[d[1]+k] + } else { + if (val2 > val3) # cba + median[i] = Mem$t[d[2]+k] + else if (val1 > val3) # bca + median[i] = Mem$t[d[3]+k] + else # bac + median[i] = Mem$t[d[1]+k] + } + $else + val1 = Mem$t[d[1]+k] + val2 = Mem$t[d[2]+k] + val3 = Mem$t[d[3]+k] + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = val2 + else if (val1 < val3) # acb + median[i] = val3 + else # cab + median[i] = val1 + } else { + if (val2 > val3) # cba + median[i] = val2 + else if (val1 > val3) # bca + median[i] = val3 + else # bac + median[i] = val1 + } + $endif + + # If 2 points average. + } else if (n1 == 2) { + val1 = Mem$t[d[1]+k] + val2 = Mem$t[d[2]+k] + median[i] = (val1 + val2) / 2 + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Mem$t[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/icmm.gx b/noao/twodspec/longslit/lscombine/src/icmm.gx new file mode 100644 index 00000000..16505588 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icmm.gx @@ -0,0 +1,189 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +$for (sird) +# IC_MM -- Reject a specified number of high and low pixels + +procedure ic_mm$t (d, m, n, npts) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line + +int n1, ncombine, npairs, nlow, nhigh, np +int i, i1, j, jmax, jmin +pointer k, kmax, kmin +PIXEL d1, d2, dmin, dmax + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + if (dflag == D_ALL) { + n1 = n[1] + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = n1 - nlow - nhigh + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + do i = 1, npts { + i1 = i - 1 + n1 = n[i] + if (dflag == D_MIX) { + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = max (ncombine, n1 - nlow - nhigh) + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + # Reject the npairs low and high points. + do np = 1, npairs { + k = d[1] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k + do j = 2, n1 { + d2 = d1 + k = d[j] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } else if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + j = n1 - 1 + if (keepids) { + if (jmax < j) { + if (jmin != j) { + Mem$t[kmax] = d2 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Mem$t[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Mem$t[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Mem$t[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } else { + if (jmax < j) { + if (jmin != j) + Mem$t[kmax] = d2 + else + Mem$t[kmax] = d1 + } + if (jmin < j) { + if (jmax != n1) + Mem$t[kmin] = d1 + else + Mem$t[kmin] = d2 + } + } + n1 = n1 - 2 + } + + # Reject the excess low points. + do np = 1, nlow { + k = d[1] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + dmin = d1; jmin = 1; kmin = k + do j = 2, n1 { + k = d[j] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + if (keepids) { + if (jmin < n1) { + Mem$t[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmin < n1) + Mem$t[kmin] = d1 + } + n1 = n1 - 1 + } + + # Reject the excess high points. + do np = 1, nhigh { + k = d[1] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + dmax = d1; jmax = 1; kmax = k + do j = 2, n1 { + k = d[j] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } + } + if (keepids) { + if (jmax < n1) { + Mem$t[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmax < n1) + Mem$t[kmax] = d1 + } + n1 = n1 - 1 + } + n[i] = n1 + } + + if (dflag == D_ALL && npairs + nlow + nhigh > 0) + dflag = D_MIX +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/icomb.gx b/noao/twodspec/longslit/lscombine/src/icomb.gx new file mode 100644 index 00000000..6c6e56c9 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icomb.gx @@ -0,0 +1,674 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <pmset.h> +include <error.h> +include <syserr.h> +include <mach.h> +include "../icombine.h" + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include <imset.h> + + +# ICOMBINE -- Combine images +# +# The memory and open file descriptor limits are checked and an attempt +# to recover is made either by setting the image pixel files to be +# closed after I/O or by notifying the calling program that memory +# ran out and the IMIO buffer size should be reduced. After the checks +# a procedure for the selected combine option is called. +# Because there may be several failure modes when reaching the file +# limits we first assume an error is due to the file limit, except for +# out of memory, and close some pixel files. If the error then repeats +# on accessing the pixels the error is passed back. + +$for (sird) +procedure icombine$t (in, out, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnl$t() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnl$t, impl1i, ic_combine$t +$if (datatype == sil) +pointer impl1r() +errchk impl1r +$else +pointer impl1$t() +errchk impl1$t +$endif + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + call salloc (dbuf, nimages, TY_POINTER) + call salloc (d, nimages, TY_POINTER) + call salloc (id, nimages, TY_POINTER) + call salloc (n, npts, TY_INT) + call salloc (m, nimages, TY_POINTER) + call salloc (lflag, nimages, TY_INT) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # If not aligned or growing create data buffers of output length + # otherwise use the IMIO buffers. + + if (!aligned || grow >= 1.) { + do i = 1, nimages + call salloc (Memi[dbuf+i-1], npts, TY_PIXEL) + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) + call salloc (Memi[dbuf+i-1], npts, TY_PIXEL) + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + } else { + # Reserve FD for string operations. + fd = stropen (str, 1, NEW_FILE) + + # Do I/O to the images. + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + $if (datatype == sil) + buf = impl1r (out[1]) + call aclrr (Memr[buf], npts) + if (out[3] != NULL) { + buf = impl1r (out[3]) + call aclrr (Memr[buf], npts) + } + $else + buf = impl1$t (out[1]) + call aclr$t (Mem$t[buf], npts) + if (out[3] != NULL) { + buf = impl1$t (out[3]) + call aclr$t (Mem$t[buf], npts) + } + $endif + if (out[2] != NULL) { + buf = impl1i (out[2]) + call aclri (Memi[buf], npts) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnl$t (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + } + } + + call strclose (fd) + } + + call ic_combine$t (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], + Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) +end + + +# IC_COMBINE -- Combine images. + +procedure ic_combine$t (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, wts, nimages, npts) + +pointer in[nimages] # Input images +pointer out[ARB] # Output image +pointer dbuf[nimages] # Data buffers for nonaligned images +pointer d[nimages] # Data pointers +pointer id[nimages] # Image index ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Line flags +int offsets[nimages,ARB] # Input image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +real wts[nimages] # Combining weights +int nimages # Number of input images +int npts # Number of points per output line + +int i, ext, ctor(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nm, pms +pointer immap(), impnli() +$if (datatype == sil) +pointer impnlr(), imgnlr() +$else +pointer impnl$t(), imgnl$t +$endif +errchk immap, ic_scale, imgetr, ic_grow, ic_grow$t, ic_rmasks, ic_gdata$t + +include "../icombine.com" +data ext/0/ + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + call ic_scale (in, out, offsets, scales, zeros, wts, nimages) + + # Set combine parameters + switch (combine) { + case AVERAGE: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Set rejection algorithm specific parameters + switch (reject) { + case CCDCLIP, CRREJECT: + call salloc (nm, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nm+3*(i-1)+2] = r + } + } + if (!keepids) { + if (doscale1) + keepids = true + else { + do i = 2, nimages { + if (Memr[nm+3*(i-1)] != Memr[nm] || + Memr[nm+3*(i-1)+1] != Memr[nm+1] || + Memr[nm+3*(i-1)+2] != Memr[nm+2]) { + keepids = true + break + } + } + } + } + if (reject == CRREJECT) + lsigma = MAX_REAL + case MINMAX: + mclip = false + case PCLIP: + mclip = true + case AVSIGCLIP, SIGCLIP: + if (doscale1) + keepids = true + case NONE: + mclip = false + } + + if (out[4] != NULL) + keepids = true + + if (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + if (grow >= 1.) { + keepids = true + call salloc (work, npts * nimages, TY_INT) + } + pms = NULL + + if (keepids) { + do i = 1, nimages + call salloc (id[i], npts, TY_INT) + } + + $if (datatype == sil) + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclip$t (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + else + call ic_accdclip$t (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + case MINMAX: + call ic_mm$t (d, id, n, npts) + case PCLIP: + call ic_pclip$t (d, id, n, nimages, npts, Memr[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclip$t (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + else + call ic_asigclip$t (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclip$t (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + else + call ic_aavsigclip$t (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, npts, YES, YES, + Memr[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, npts, YES, NO, + Memr[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigma$t (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + $else + while (impnl$t (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclip$t (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Mem$t[outdata]) + else + call ic_accdclip$t (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Mem$t[outdata]) + case MINMAX: + call ic_mm$t (d, id, n, npts) + case PCLIP: + call ic_pclip$t (d, id, n, nimages, npts, Mem$t[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclip$t (d, id, n, scales, zeros, nimages, npts, + Mem$t[outdata]) + else + call ic_asigclip$t (d, id, n, scales, zeros, nimages, npts, + Mem$t[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclip$t (d, id, n, scales, zeros, nimages, + npts, Mem$t[outdata]) + else + call ic_aavsigclip$t (d, id, n, scales, zeros, nimages, + npts, Mem$t[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, npts, YES, YES, + Mem$t[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, YES, Mem$t[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, npts, YES, NO, + Mem$t[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnl$t (out[3], buf, Meml[v1]) + call ic_sigma$t (d, id, n, wts, npts, Mem$t[outdata], + Mem$t[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + $endif + + if (pms != NULL) { + if (nkeep > 0) { + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call imunmap (out[1]) + iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { + switch (errcode()) { + case SYS_FXFOPNOEXTNV: + call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) + ext = ext + 1 + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext) + iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { + buf = NULL + ext = 0 + } + repeat { + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext+1) + iferr (outdata = immap (Memc[imname],READ_WRITE,0)) + break + if (buf != NULL) + call imunmap (buf) + buf = outdata + ext = ext + 1 + } + default: + call erract (EA_ERROR) + } + } + out[1] = buf + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + $if (datatype == sil) + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_grow$t (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnlr (out[1], buf, Meml[v1]) == EOF) + ; + call amovr (Memr[buf], Memr[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, npts, NO, YES, + Memr[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, npts, NO, NO, + Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigma$t (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + $else + while (impnl$t (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_grow$t (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnl$t (out[1], buf, Meml[v1]) == EOF) + ; + call amov$t (Mem$t[buf], Mem$t[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, npts, NO, YES, + Mem$t[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, NO, Mem$t[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, npts, NO, NO, + Mem$t[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 0 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnl$t (out[3], buf, Meml[v1]) + call ic_sigma$t (d, id, n, wts, npts, Mem$t[outdata], + Mem$t[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + $endif + + do i = 1, nimages + call pm_close (Memi[pms+i-1]) + call mfree (pms, TY_POINTER) + } + + call sfree (sp) +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/icombine.com b/noao/twodspec/longslit/lscombine/src/icombine.com new file mode 100644 index 00000000..7fa34287 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icombine.com @@ -0,0 +1,45 @@ +# ICOMBINE Common + +int combine # Combine algorithm +int reject # Rejection algorithm +bool project # Combine across the highest dimension? +real blank # Blank value +pointer ictask # Task name for log +pointer expkeyword # Exposure time keyword +pointer statsec # Statistics section +pointer rdnoise # CCD read noise +pointer gain # CCD gain +pointer snoise # CCD sensitivity noise +real lthresh # Low threshold +real hthresh # High threshold +int nkeep # Minimum to keep +real lsigma # Low sigma cutoff +real hsigma # High sigma cutoff +real pclip # Number or fraction of pixels from median +real flow # Fraction of low pixels to reject +real fhigh # Fraction of high pixels to reject +real grow # Grow radius +bool mclip # Use median in sigma clipping? +real sigscale # Sigma scaling tolerance +int logfd # Log file descriptor + +# These flags allow special conditions to be optimized. + +int dflag # Data flag (D_ALL, D_NONE, D_MIX) +bool aligned # Are the images aligned? +bool doscale # Do the images have to be scaled? +bool doscale1 # Do the sigma calculations have to be scaled? +bool dothresh # Check pixels outside specified thresholds? +bool dowts # Does the final average have to be weighted? +bool keepids # Keep track of the image indices? +bool docombine # Call the combine procedure? +bool sort # Sort data? +bool verbose # Verbose? + +pointer icm # Mask data structure + +common /imccom/ combine, reject, blank, ictask, expkeyword, statsec, rdnoise, + gain, snoise, lsigma, hsigma, lthresh, hthresh, nkeep, + pclip, flow, fhigh, grow, logfd, dflag, sigscale, project, + mclip, aligned, doscale, doscale1, dothresh, dowts, + keepids, docombine, sort, verbose, icm diff --git a/noao/twodspec/longslit/lscombine/src/icombine.h b/noao/twodspec/longslit/lscombine/src/icombine.h new file mode 100644 index 00000000..016172de --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icombine.h @@ -0,0 +1,53 @@ +# ICOMBINE Definitions + +# Memory management parameters; +define MAXMEMORY 250000000 # maximum memory +define FUDGE 0.8 # fudge factor + +# Rejection options: +define REJECT "|none|ccdclip|crreject|minmax|pclip|sigclip|avsigclip|" +define NONE 1 # No rejection algorithm +define CCDCLIP 2 # CCD noise function clipping +define CRREJECT 3 # CCD noise function clipping +define MINMAX 4 # Minmax rejection +define PCLIP 5 # Percentile clip +define SIGCLIP 6 # Sigma clip +define AVSIGCLIP 7 # Sigma clip with average poisson sigma + +# Combine options: +define COMBINE "|average|median|sum|" +define AVERAGE 1 +define MEDIAN 2 +define SUM 3 + +# Scaling options: +define STYPES "|none|mode|median|mean|exposure|" +define ZTYPES "|none|mode|median|mean|" +define WTYPES "|none|mode|median|mean|exposure|" +define S_NONE 1 +define S_MODE 2 +define S_MEDIAN 3 +define S_MEAN 4 +define S_EXPOSURE 5 +define S_FILE 6 +define S_KEYWORD 7 +define S_SECTION "|input|output|overlap|" +define S_INPUT 1 +define S_OUTPUT 2 +define S_OVERLAP 3 + +# Mask options +define MASKTYPES "|none|goodvalue|badvalue|goodbits|badbits|" +define M_NONE 1 # Don't use mask images +define M_GOODVAL 2 # Value selecting good pixels +define M_BADVAL 3 # Value selecting bad pixels +define M_GOODBITS 4 # Bits selecting good pixels +define M_BADBITS 5 # Bits selecting bad pixels +define M_BOOLEAN -1 # Ignore mask values + +# Data flag +define D_ALL 0 # All pixels are good +define D_NONE 1 # All pixels are bad or rejected +define D_MIX 2 # Mixture of good and bad pixels + +define TOL 0.001 # Tolerance for equal residuals diff --git a/noao/twodspec/longslit/lscombine/src/icombine.x b/noao/twodspec/longslit/lscombine/src/icombine.x new file mode 100644 index 00000000..d7b1d1e7 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icombine.x @@ -0,0 +1,476 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <error.h> +include <syserr.h> +include "icombine.h" + + +# ICOMBINE -- Combine input list or image. +# This procedure maps the images, sets the output dimensions and datatype, +# opens the logfile, and sets IMIO parameters. It attempts to adjust +# buffer sizes and memory requirements for maximum efficiency. + +procedure icombine (list, output, headers, bmask, rmask, nrmask, emask, + sigma, logfile, scales, zeros, wts, stack, delete) + +int list #I List of input images +char output[ARB] #I Output image +char headers[ARB] #I Output header rootname +char bmask[ARB] #I Bad pixel mask +char rmask[ARB] #I Rejection mask +char nrmask[ARB] #I Nreject mask +char emask[ARB] #I Exposure mask +char sigma[ARB] #I Sigma image (optional) +char logfile[ARB] #I Logfile (optional) +real scales[ARB] #I Scale factors +real zeros[ARB] #I Offset factors +real wts[ARB] #I Weights +int stack #I Stack input images? +int delete #I Delete input images? + +bool proj +char input[SZ_FNAME], errstr[SZ_LINE] +int i, j, nimages, intype, bufsize, maxsize, memory, oldsize, stack1, err +pointer sp, im, in1, in, out[6], offsets, key, tmp, bpmstack + +char clgetc() +int clgwrd(), imtlen(), imtgetim(), imtrgetim(), getdatatype() +int begmem(), errget(), open(), ty_max(), sizeof(), strmatch() +pointer immap(), xt_immap(), ic_pmmap() +errchk ic_imstack, immap, imunmap, xt_immap, ic_pmmap, ic_setout + +include "icombine.com" + +define retry_ 98 +define err_ 99 + +begin + nimages = imtlen (list) + if (nimages == 0) + call error (1, "No images to combine") + + if (project) { + if (imtgetim (list, input, SZ_FNAME) == EOF) + call error (1, "No image to project") + } + + bufsize = 0 +# if (nimages > LAST_FD - 15) +# stack1 = YES +# else + stack1 = stack + +retry_ + iferr { + call smark (sp) + call salloc (in, 1, TY_POINTER) + + nimages = 0 + in1 = NULL; Memi[in] = NULL; logfd = NULL + out[1] = NULL; out[2] = NULL; out[3] = NULL + out[4] = NULL; out[5] = NULL; out[6] = NULL + + # Stack the input images. + if (stack1 == YES) { + proj = project + project = true + call salloc (bpmstack, SZ_FNAME, TY_CHAR) + i = clgwrd ("masktype", Memc[bpmstack], SZ_FNAME, MASKTYPES) + if (i == M_NONE) + Memc[bpmstack] = EOS + else { + call mktemp ("tmp", Memc[bpmstack], SZ_FNAME) + call strcat (".pl", Memc[bpmstack], SZ_FNAME) + } + call mktemp ("tmp", input, SZ_FNAME) + call imtrew (list) + call ic_imstack (list, input, Memc[bpmstack]) + } + + # Open the input image(s). + if (project) { + tmp = immap (input, READ_ONLY, 0); out[1] = tmp + if (IM_NDIM(out[1]) == 1) + call error (1, "Can't project one dimensional images") + nimages = IM_LEN(out[1],IM_NDIM(out[1])) + call salloc (in, nimages, TY_POINTER) + call amovki (out[1], Memi[in], nimages) + } else { + call salloc (in, imtlen(list), TY_POINTER) + call amovki (NULL, Memi[in], imtlen(list)) + call imtrew (list) + while (imtgetim (list, input, SZ_FNAME)!=EOF) { + nimages = nimages + 1 + tmp = xt_immap (input, READ_ONLY, 0, nimages) + Memi[in+nimages-1] = tmp + } + + # Check sizes and set I/O option. + intype = 0 + tmp = Memi[in] + do i = 2, nimages { + do j = 1, IM_NDIM(tmp) { + if (IM_LEN(tmp,j) != IM_LEN(Memi[in+i-1],j)) + intype = 1 + } + if (intype == 1) + break + } + if (intype == 1) + call xt_imseti (0, "option", intype) + } + + # Check if there are no images. + if (nimages == 0) + call error (1, "No images to combine") + + # Convert the pclip parameter to a number of pixels rather than + # a fraction. This number stays constant even if pixels are + # rejected. The number of low and high pixel rejected, however, + # are converted to a fraction of the valid pixels. + + if (reject == PCLIP) { + i = nimages / 2. + if (abs (pclip) < 1.) + pclip = pclip * i + if (pclip < 0.) + pclip = min (-1, max (-i, int (pclip))) + else + pclip = max (1, min (i, int (pclip))) + } + + if (reject == MINMAX) { + if (flow >= 1) + flow = flow / nimages + if (fhigh >= 1) + fhigh = fhigh / nimages + i = flow * nimages + j = fhigh * nimages + if (i + j == 0) + reject = NONE + else if (i + j >= nimages) + call error (1, "Bad minmax rejection parameters") + } + + # Map the output image and set dimensions and offsets. + if (stack1 == YES) { + call imtrew (list) + i = imtgetim (list, errstr, SZ_LINE) + in1 = immap (errstr, READ_ONLY, 0) + tmp = immap (output, NEW_COPY, in1); out[1] = tmp + call salloc (key, SZ_FNAME, TY_CHAR) + do i = 1, nimages { + call sprintf (Memc[key], SZ_FNAME, "stck%04d") + call pargi (i) + iferr (call imdelf (out[1], Memc[key])) + ; + if (Memc[bpmstack] != EOS) { + call sprintf (Memc[key], SZ_FNAME, "bpm%04d") + call pargi (i) + iferr (call imdelf (out[1], Memc[key])) + ; + } + } + } else { + tmp = immap (output, NEW_COPY, Memi[in]); out[1] = tmp + if (project) { + IM_LEN(out[1],IM_NDIM(out[1])) = 1 + IM_NDIM(out[1]) = IM_NDIM(out[1]) - 1 + } + } + call salloc (offsets, nimages*IM_NDIM(out[1]), TY_INT) + iferr (call ic_setout (Memi[in], out, Memi[offsets], nimages)) { + call erract (EA_WARN) + call error (1, "Can't set output geometry") + } + call ic_hdr (Memi[in], out, nimages) + iferr (call imdelf (out, "BPM")) + ; + iferr (call imdelf (out, "ICFNAME")) + ; + + # Determine the highest precedence datatype and set output datatype. + intype = IM_PIXTYPE(Memi[in]) + do i = 2, nimages + intype = ty_max (intype, IM_PIXTYPE(Memi[in+i-1])) + IM_PIXTYPE(out[1]) = getdatatype (clgetc ("outtype")) + if (IM_PIXTYPE(out[1]) == ERR) + IM_PIXTYPE(out[1]) = intype + + # Open rejection masks + if (rmask[1] != EOS) { + tmp = ic_pmmap (rmask, NEW_COPY, out[1]); out[4] = tmp + IM_NDIM(out[4]) = IM_NDIM(out[4]) + 1 + IM_LEN(out[4],IM_NDIM(out[4])) = nimages + if (!project) { + if (key == NULL) + call salloc (key, SZ_FNAME, TY_CHAR) + do i = 100, nimages { + j = imtrgetim (list, i, input, SZ_FNAME) + if (i < 999) + call sprintf (Memc[key], SZ_FNAME, "imcmb%d") + else if (i < 9999) + call sprintf (Memc[key], SZ_FNAME, "imcm%d") + else + call sprintf (Memc[key], SZ_FNAME, "imc%d") + call pargi (i) + call imastr (out[4], Memc[key], input) + } + } + } else + out[4] = NULL + + # Open bad pixel pixel list file if given. + if (bmask[1] != EOS) { + tmp = ic_pmmap (bmask, NEW_COPY, out[1]); out[2] = tmp + } else + out[2] = NULL + + # Open nreject pixel list file if given. + if (nrmask[1] != EOS) { + tmp = ic_pmmap (nrmask, NEW_COPY, out[1]); out[5] = tmp + } else + out[5] = NULL + + # Open exposure mask if given. + if (emask[1] != EOS) { + tmp = ic_pmmap (emask, NEW_COPY, out[1]); out[6] = tmp + } else + out[6] = NULL + + # Open the sigma image if given. + if (sigma[1] != EOS) { + tmp = immap (sigma, NEW_COPY, out[1]); out[3] = tmp + IM_PIXTYPE(out[3]) = ty_max (TY_REAL, IM_PIXTYPE(out[1])) + call sprintf (IM_TITLE(out[3]), SZ_IMTITLE, + "Combine sigma images for %s") + call pargstr (output) + } else + out[3] = NULL + + # Open masks. + call ic_mopen (Memi[in], out, nimages, Memi[offsets]) + + # Open the log file. + logfd = NULL + if (logfile[1] != EOS) { + iferr (logfd = open (logfile, APPEND, TEXT_FILE)) { + logfd = NULL + call erract (EA_WARN) + } + } + + if (bufsize == 0) { + # Set initial IMIO buffer size based on the number of images + # and maximum amount of working memory available. The buffer + # size may be adjusted later if the task runs out of memory. + # The FUDGE factor is used to allow for the size of the + # program, memory allocator inefficiencies, and any other + # memory requirements besides IMIO. + + memory = begmem (0, oldsize, maxsize) + memory = min (memory, maxsize, MAXMEMORY) + bufsize = FUDGE * memory / (nimages + 1) / sizeof (intype) + } + + # Combine the images. If an out of memory error occurs close all + # images and files, divide the IMIO buffer size in half and try + # again. + + switch (ty_max (intype, IM_PIXTYPE(out[1]))) { + case TY_SHORT: + call icombines (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + case TY_USHORT, TY_INT, TY_LONG: + call icombinei (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + case TY_DOUBLE: + call icombined (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + case TY_COMPLEX: + call error (1, "Complex images not allowed") + default: + call icombiner (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + } + } then { + err = errget (errstr, SZ_LINE) + if (err == SYS_IKIOPIX && nimages < 250) + err = SYS_MFULL + call ic_mclose (nimages) + if (!project) { + do j = 2, nimages { + if (Memi[in+j-1] != NULL) + call xt_imunmap (Memi[in+j-1], j) + } + } + if (out[2] != NULL) { + call imunmap (out[2]) + iferr (call imdelete (bmask)) + ; + } + if (out[3] != NULL) { + call imunmap (out[3]) + iferr (call imdelete (sigma)) + ; + } + if (out[4] != NULL) { + call imunmap (out[4]) + iferr (call imdelete (rmask)) + ; + } + if (out[5] != NULL) { + call imunmap (out[5]) + iferr (call imdelete (nrmask)) + ; + } + if (out[6] != NULL) { + call imunmap (out[6]) + iferr (call imdelete (emask)) + ; + } + if (out[1] != NULL) { + call imunmap (out[1]) + iferr (call imdelete (output)) + ; + } + if (Memi[in] != NULL) + call xt_imunmap (Memi[in], 1) + if (in1 != NULL) + call imunmap (in1) + if (logfd != NULL) + call close (logfd) + + switch (err) { + case SYS_MFULL: + if (project) + goto err_ + + if (bufsize < 10000) { + call strcat ("- Maybe min_lenuserarea is too large", + errstr, SZ_LINE) + goto err_ + } + + bufsize = bufsize / 2 + call sfree (sp) + goto retry_ + case SYS_FTOOMANYFILES, SYS_IKIOPEN, SYS_IKIOPIX, SYS_FOPEN, SYS_FWTNOACC: + if (project) + goto err_ + stack1 = YES + call sfree (sp) + goto retry_ + default: +err_ + if (stack1 == YES) { + iferr (call imdelete (input)) + ; + if (Memc[bpmstack] != EOS) { + iferr (call imdelete (Memc[bpmstack])) + ; + } + } + call fixmem (oldsize) + while (imtgetim (list, input, SZ_FNAME)!=EOF) + ; + call sfree (sp) + call error (err, errstr) + } + } + + # Unmap all the images, close the log file, and restore memory. + if (out[2] != NULL) + iferr (call imunmap (out[2])) + call erract (EA_WARN) + if (out[3] != NULL) + iferr (call imunmap (out[3])) + call erract (EA_WARN) + if (out[4] != NULL) { + # Close the output first so that there is no confusion with + # inheriting the output header. Then update the WCS for the + # extra dimension. Note that this may not be correct with + # axis reduced WCS. + iferr { + call imunmap (out[4]) + out[4] = immap (rmask, READ_WRITE, 0) + i = IM_NDIM(out[4]) + call imaddi (out[4], "WCSDIM", i) + call sprintf (errstr, SZ_LINE, "LTM%d_%d") + call pargi (i) + call pargi (i) + call imaddr (out[4], errstr, 1.) + call sprintf (errstr, SZ_LINE, "CD%d_%d") + call pargi (i) + call pargi (i) + call imaddr (out[4], errstr, 1.) + call imunmap (out[4]) + } then + call erract (EA_WARN) + } + if (out[5] != NULL) + iferr (call imunmap (out[5])) + call erract (EA_WARN) + if (out[6] != NULL) + iferr (call imunmap (out[6])) + call erract (EA_WARN) + if (out[1] != NULL) { + call imunmap (out[1]) + if (headers[1] != EOS) { + # Write input headers to a multiextension file if desired. + # This might be the same as the output image. + iferr { + do i = 1, nimages { + im = Memi[in+i-1] + call imstats (im, IM_IMAGENAME, input, SZ_FNAME) + if (strmatch (headers, ".fits$") == 0) { + call sprintf (errstr, SZ_LINE, "%s.fits[append]") + call pargstr (headers) + } else { + call sprintf (errstr, SZ_LINE, "%s[append]") + call pargstr (headers) + } + tmp = immap (errstr, NEW_COPY, im) + IM_NDIM(tmp) = 0 + do j = 1, IM_NDIM(im) { + call sprintf (errstr, SZ_LINE, "AXLEN%d") + call pargi (j) + call imaddi (tmp, errstr, IM_LEN(im,j)) + } + call imastr (tmp, "INIMAGE", input) + call imastr (tmp, "OUTIMAGE", output) + call imastr (tmp, "EXTNAME", input) + call imunmap (tmp) + } + if (logfd != NULL) { + call eprintf (" Headers = %s\n") + call pargstr (headers) + } + } then + call erract (EA_WARN) + } + } + if (!project) { + do i = 2, nimages { + if (Memi[in+i-1] != NULL) + call xt_imunmap (Memi[in+i-1], i) + } + } + if (Memi[in] != NULL) + call xt_imunmap (Memi[in], 1) + if (in1 != NULL) + call imunmap (in1) + if (stack1 == YES) { + call imdelete (input) + if (Memc[bpmstack] != EOS) + call imdelete (Memc[bpmstack]) + project = proj + } + if (logfd != NULL) + call close (logfd) + call ic_mclose (nimages) + call fixmem (oldsize) + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lscombine/src/icpclip.gx b/noao/twodspec/longslit/lscombine/src/icpclip.gx new file mode 100644 index 00000000..f0c76369 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icpclip.gx @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Minimum number for clipping + +$for (sird) +# IC_PCLIP -- Percentile clip +# +# 1) Find the median +# 2) Find the pixel which is the specified order index away +# 3) Use the data value difference as a sigma and apply clipping +# 4) Since the median is known return it so it does not have to be recomputed + +procedure ic_pclip$t (d, m, n, nimages, npts, median) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of input images +int npts # Number of output points per line +$if (datatype == sil) +real median[npts] # Median +$else +PIXEL median[npts] # Median +$endif + +int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep +bool even, fp_equalr() +real sigma, r, s, t +pointer sp, resid, mp1, mp2 +$if (datatype == sil) +real med +$else +PIXEL med +$endif + +include "../icombine.com" + +begin + # There must be at least MINCLIP and more than nkeep pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Set sign of pclip parameter + if (pclip < 0) + t = -1. + else + t = 1. + + # If there are no rejected pixels compute certain parameters once. + if (dflag == D_ALL) { + n1 = n[1] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0.) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + nin = n1 + } + + # Now apply clipping. + do i = 1, npts { + # Compute median. + if (dflag == D_MIX) { + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 == 0) { + if (combine == MEDIAN) + median[i] = blank + next + } + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + } + + j = i - 1 + if (even) { + med = Mem$t[d[n2-1]+j] + med = (med + Mem$t[d[n2]+j]) / 2. + } else + med = Mem$t[d[n2]+j] + + if (n1 < max (MINCLIP, maxkeep+1)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Define sigma for clipping + sigma = t * (Mem$t[d[n3]+j] - med) + if (fp_equalr (sigma, 0.)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Reject pixels and save residuals. + # Check if any pixels are clipped. + # If so recompute the median and reset the number of good pixels. + # Only reorder if needed. + + for (nl=1; nl<=n1; nl=nl+1) { + r = (med - Mem$t[d[nl]+j]) / sigma + if (r < lsigma) + break + Memr[resid+nl] = r + } + for (nh=n1; nh>=1; nh=nh-1) { + r = (Mem$t[d[nh]+j] - med) / sigma + if (r < hsigma) + break + Memr[resid+nh] = r + } + n4 = nh - nl + 1 + + # If too many pixels are rejected add some back in. + # All pixels with the same residual are added. + while (n4 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n4 = nh - nl + 1 + } + + # If any pixels are rejected recompute the median. + if (nl > 1 || nh < n1) { + n5 = nl + n4 / 2 + if (mod (n4, 2) == 0) { + med = Mem$t[d[n5-1]+j] + med = (med + Mem$t[d[n5]+j]) / 2. + } else + med = Mem$t[d[n5]+j] + n[i] = n4 + } + if (combine == MEDIAN) + median[i] = med + + # Reorder if pixels only if necessary. + if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mem$t[d[l]+j] = Mem$t[d[k]+j] + if (grow >= 1.) { + mp1 = m[l] + j + mp2 = m[k] + j + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+j] = Memi[m[k]+j] + k = k + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mem$t[d[l]+j] = Mem$t[d[k]+j] + k = k + 1 + } + } + } + } + + # Check if data flag needs to be reset for rejected pixels. + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag whether the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/icpmmap.x b/noao/twodspec/longslit/lscombine/src/icpmmap.x new file mode 100644 index 00000000..1afeedd7 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icpmmap.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <pmset.h> + + +# IC_PMMAP -- Map pixel mask. + +pointer procedure ic_pmmap (fname, mode, refim) + +char fname[ARB] # Mask name +int mode # Image mode +pointer refim # Reference image +pointer pm # IMIO pointer (returned) + +int i, fnextn() +pointer sp, extn, immap() +bool streq() + +begin + call smark (sp) + call salloc (extn, SZ_FNAME, TY_CHAR) + + i = fnextn (fname, Memc[extn], SZ_FNAME) + if (streq (Memc[extn], "pl")) + pm = immap (fname, mode, refim) + else { + call strcpy (fname, Memc[extn], SZ_FNAME) + call strcat (".pl", Memc[extn], SZ_FNAME) + pm = immap (Memc[extn], mode, refim) + } + + call sfree (sp) + return (pm) +end diff --git a/noao/twodspec/longslit/lscombine/src/icrmasks.x b/noao/twodspec/longslit/lscombine/src/icrmasks.x new file mode 100644 index 00000000..8b9a0c3d --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icrmasks.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + + +# IC_RMASKS -- Set pixels for rejection mask. + +procedure ic_rmasks (pm, v, id, nimages, n, npts) + +pointer pm #I Pixel mask +long v[ARB] #I Output vector (input) +pointer id[nimages] #I Image id pointers +int nimages #I Number of images +int n[npts] #I Number of good pixels +int npts #I Number of output points per line + +int i, j, k, ndim, impnls() +long v1[IM_MAXDIM] +pointer buf + +begin + ndim = IM_NDIM(pm) + do k = 1, nimages { + call amovl (v, v1, ndim-1) + v1[ndim] = k + i = impnls (pm, buf, v1) + do j = 1, npts { + if (n[j] == nimages) + Mems[buf+j-1] = 0 + else { + Mems[buf+j-1] = 1 + do i = 1, n[j] { + if (Memi[id[i]+j-1] == k) { + Mems[buf+j-1] = 0 + break + } + } + } + } + } +end diff --git a/noao/twodspec/longslit/lscombine/src/icscale.x b/noao/twodspec/longslit/lscombine/src/icscale.x new file mode 100644 index 00000000..42d62f8d --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icscale.x @@ -0,0 +1,351 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include "icombine.h" + + +# IC_SCALE -- Get and set the scaling factors. +# +# If the scaling parameters have been set earlier then this routine +# just normalizes the factors and writes the log output. +# When dealing with individual images using image statistics for scaling +# factors this routine determines the image statistics rather than being +# done earlier since the input images have all been mapped at this stage. + +procedure ic_scale (in, out, offsets, scales, zeros, wts, nimages) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero or sky levels +real wts[nimages] # Weights +int nimages # Number of images + +int stype, ztype, wtype +int i, j, k, l, nout +real mode, median, mean, sumwts +pointer sp, ncombine, exptime, modes, medians, means +pointer section, str, sname, zname, wname, im, imref +bool domode, domedian, domean, dozero, dos, doz, dow, snorm, znorm, wflag + +int imgeti(), strdic(), ic_gscale() +real imgetr(), asumr(), asumi() +pointer xt_opix() +errchk ic_gscale, xt_opix, ic_statr + +include "icombine.com" + +begin + call smark (sp) + call salloc (ncombine, nimages, TY_INT) + call salloc (exptime, nimages, TY_REAL) + call salloc (modes, nimages, TY_REAL) + call salloc (medians, nimages, TY_REAL) + call salloc (means, nimages, TY_REAL) + call salloc (section, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (sname, SZ_FNAME, TY_CHAR) + call salloc (zname, SZ_FNAME, TY_CHAR) + call salloc (wname, SZ_FNAME, TY_CHAR) + + # Get the number of images previously combined and the exposure times. + # The default combine number is 1 and the default exposure is 0. + + do i = 1, nimages { + iferr (Memi[ncombine+i-1] = imgeti (in[i], "ncombine")) + Memi[ncombine+i-1] = 1 + if (Memc[expkeyword] != EOS) { + iferr (Memr[exptime+i-1] = imgetr (in[i], Memc[expkeyword])) + Memr[exptime+i-1] = 0. + } else + Memr[exptime+i-1] = 0. + if (project) { + call amovki (Memi[ncombine], Memi[ncombine], nimages) + call amovkr (Memr[exptime], Memr[exptime], nimages) + break + } + } + + # Set scaling type and factors. + stype = ic_gscale ("scale", Memc[sname], STYPES, in, Memr[exptime], + scales, nimages) + ztype = ic_gscale ("zero", Memc[zname], ZTYPES, in, Memr[exptime], + zeros, nimages) + wtype = ic_gscale ("weight", Memc[wname], WTYPES, in, Memr[exptime], + wts, nimages) + + # Get image statistics if needed. + dos = ((stype==S_MODE)||(stype==S_MEDIAN)||(stype==S_MEAN)) + doz = ((ztype==S_MODE)||(ztype==S_MEDIAN)||(ztype==S_MEAN)) + dow = ((wtype==S_MODE)||(wtype==S_MEDIAN)||(wtype==S_MEAN)) + if (dos) { + dos = false + do i = 1, nimages + if (IS_INDEFR(scales[i])) { + dos = true + break + } + } + if (doz) { + doz = false + do i = 1, nimages + if (IS_INDEFR(zeros[i])) { + doz = true + break + } + } + if (dow) { + dow = false + do i = 1, nimages + if (IS_INDEFR(wts[i])) { + dow = true + break + } + } + + if (dos || doz || dow) { + domode = ((stype==S_MODE)||(ztype==S_MODE)||(wtype==S_MODE)) + domedian = ((stype==S_MEDIAN)||(ztype==S_MEDIAN)||(wtype==S_MEDIAN)) + domean = ((stype==S_MEAN)||(ztype==S_MEAN)||(wtype==S_MEAN)) + + Memc[section] = EOS + Memc[str] = EOS + call sscan (Memc[statsec]) + call gargwrd (Memc[section], SZ_FNAME) + call gargwrd (Memc[str], SZ_LINE) + + i = strdic (Memc[section], Memc[section], SZ_FNAME, S_SECTION) + switch (i) { + case S_INPUT: + call strcpy (Memc[str], Memc[section], SZ_FNAME) + imref = NULL + case S_OUTPUT: + call strcpy (Memc[str], Memc[section], SZ_FNAME) + imref = out[1] + case S_OVERLAP: + call strcpy ("[", Memc[section], SZ_FNAME) + do i = 1, IM_NDIM(out[1]) { + k = offsets[1,i] + 1 + l = offsets[1,i] + IM_LEN(in[1],i) + do j = 2, nimages { + k = max (k, offsets[j,i]+1) + l = min (l, offsets[j,i]+IM_LEN(in[j],i)) + } + if (i < IM_NDIM(out[1])) + call sprintf (Memc[str], SZ_LINE, "%d:%d,") + else + call sprintf (Memc[str], SZ_LINE, "%d:%d]") + call pargi (k) + call pargi (l) + call strcat (Memc[str], Memc[section], SZ_FNAME) + } + imref = out[1] + default: + imref = NULL + } + + do i = 1, nimages { + im = xt_opix (in[i], i, 0) + if (imref != out[1]) + imref = im + if ((dos && IS_INDEFR(scales[i])) || + (doz && IS_INDEFR(zeros[i])) || + (dow && IS_INDEFR(wts[i]))) { + call ic_statr (im, imref, Memc[section], offsets, i, + nimages, domode, domedian, domean, mode, median, mean) + if (domode) { + if (stype == S_MODE && IS_INDEFR(scales[i])) + scales[i] = mode + if (ztype == S_MODE && IS_INDEFR(zeros[i])) + zeros[i] = mode + if (wtype == S_MODE && IS_INDEFR(wts[i])) + wts[i] = mode + } + if (domedian) { + if (stype == S_MEDIAN && IS_INDEFR(scales[i])) + scales[i] = median + if (ztype == S_MEDIAN && IS_INDEFR(zeros[i])) + zeros[i] = median + if (wtype == S_MEDIAN && IS_INDEFR(wts[i])) + wts[i] = median + } + if (domean) { + if (stype == S_MEAN && IS_INDEFR(scales[i])) + scales[i] = mean + if (ztype == S_MEAN && IS_INDEFR(zeros[i])) + zeros[i] = mean + if (wtype == S_MEAN && IS_INDEFR(wts[i])) + wts[i] = mean + } + } + } + } + + # Save the image statistics if computed. + call amovkr (INDEFR, Memr[modes], nimages) + call amovkr (INDEFR, Memr[medians], nimages) + call amovkr (INDEFR, Memr[means], nimages) + if (stype == S_MODE) + call amovr (scales, Memr[modes], nimages) + if (stype == S_MEDIAN) + call amovr (scales, Memr[medians], nimages) + if (stype == S_MEAN) + call amovr (scales, Memr[means], nimages) + if (ztype == S_MODE) + call amovr (zeros, Memr[modes], nimages) + if (ztype == S_MEDIAN) + call amovr (zeros, Memr[medians], nimages) + if (ztype == S_MEAN) + call amovr (zeros, Memr[means], nimages) + if (wtype == S_MODE) + call amovr (wts, Memr[modes], nimages) + if (wtype == S_MEDIAN) + call amovr (wts, Memr[medians], nimages) + if (wtype == S_MEAN) + call amovr (wts, Memr[means], nimages) + + # If nothing else has set the scaling factors set them to defaults. + do i = 1, nimages { + if (IS_INDEFR(scales[i])) + scales[i] = 1. + if (IS_INDEFR(zeros[i])) + zeros[i] = 0. + if (IS_INDEFR(wts[i])) + wts[i] = 1. + } + + do i = 1, nimages + if (scales[i] <= 0.) { + call eprintf ("WARNING: Negative scale factors") + call eprintf (" -- ignoring scaling\n") + call amovkr (1., scales, nimages) + break + } + + # Convert to factors relative to the first image. + snorm = (stype == S_FILE || stype == S_KEYWORD) + znorm = (ztype == S_FILE || ztype == S_KEYWORD) + wflag = (wtype == S_FILE || wtype == S_KEYWORD) + if (snorm) + call arcpr (1., scales, scales, nimages) + mean = scales[1] + call adivkr (scales, mean, scales, nimages) + call adivr (zeros, scales, zeros, nimages) + + if (wtype != S_NONE) { + do i = 1, nimages { + if (wts[i] < 0.) { + call eprintf ("WARNING: Negative weights") + call eprintf (" -- using only NCOMBINE weights\n") + do j = 1, nimages + wts[j] = Memi[ncombine+j-1] + break + } + if (ztype == S_NONE || znorm || wflag) + wts[i] = Memi[ncombine+i-1] * wts[i] + else { + if (zeros[i] <= 0.) { + call eprintf ("WARNING: Negative zero offsets") + call eprintf (" -- ignoring zero weight adjustments\n") + do j = 1, nimages + wts[j] = Memi[ncombine+j-1] * wts[j] + break + } + wts[i] = Memi[ncombine+i-1] * wts[i] * zeros[1] / zeros[i] + } + } + } + + if (znorm) + call anegr (zeros, zeros, nimages) + else { + # Because of finite arithmetic it is possible for the zero offsets + # to be nonzero even when they are all equal. Just for the sake of + # a nice log set the zero offsets in this case. + + mean = zeros[1] + call asubkr (zeros, mean, zeros, nimages) + for (i=2; (i<=nimages)&&(zeros[i]==zeros[1]); i=i+1) + ; + if (i > nimages) + call aclrr (zeros, nimages) + } + mean = asumr (wts, nimages) + if (mean > 0.) + call adivkr (wts, mean, wts, nimages) + else { + call eprintf ("WARNING: Mean weight is zero -- using no weights\n") + call amovkr (1., wts, nimages) + mean = 1. + } + + # Set flags for scaling, zero offsets, sigma scaling, weights. + # Sigma scaling may be suppressed if the scales or zeros are + # different by a specified tolerance. + + doscale = false + dozero = false + doscale1 = false + dowts = false + do i = 2, nimages { + if (snorm || scales[i] != scales[1]) + doscale = true + if (znorm || zeros[i] != zeros[1]) + dozero = true + if (wts[i] != wts[1]) + dowts = true + } + if (doscale && sigscale != 0.) { + do i = 1, nimages { + if (abs (scales[i] - 1) > sigscale) { + doscale1 = true + break + } + } + } + + # Set the output header parameters. + nout = asumi (Memi[ncombine], nimages) + call imaddi (out[1], "ncombine", nout) + mean = 0. + sumwts = 0. + do i = 1, nimages { + ifnoerr (mode = imgetr (in[i], "ccdmean")) { + mean = mean + wts[i] * mode / scales[i] + sumwts = sumwts + wts[i] + } + } + if (sumwts > 0.) { + mean = mean / sumwts + ifnoerr (mode = imgetr (out[1], "ccdmean")) { + call imaddr (out[1], "ccdmean", mean) + iferr (call imdelf (out[1], "ccdmeant")) + ; + } + } + if (out[2] != NULL) { + call imstats (out[2], IM_IMAGENAME, Memc[str], SZ_FNAME) + call imastr (out[1], "BPM", Memc[str]) + } + + # Start the log here since much of the info is only available here. + if (verbose) { + i = logfd + logfd = STDOUT + call ic_log (in, out, Memi[ncombine], Memr[exptime], Memc[sname], + Memc[zname], Memc[wname], Memr[modes], Memr[medians], + Memr[means], scales, zeros, wts, offsets, nimages, dozero, + nout) + + logfd = i + } + call ic_log (in, out, Memi[ncombine], Memr[exptime], Memc[sname], + Memc[zname], Memc[wname], Memr[modes], Memr[medians], Memr[means], + scales, zeros, wts, offsets, nimages, dozero, nout) + + doscale = (doscale || dozero) + + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lscombine/src/icsclip.gx b/noao/twodspec/longslit/lscombine/src/icsclip.gx new file mode 100644 index 00000000..1b1c5de9 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icsclip.gx @@ -0,0 +1,504 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Mininum number of images for algorithm + +$for (sird) +# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average +# The initial average rejects the high and low pixels. A correction for +# different scalings of the images may be made. Weights are not used. + +procedure ic_asigclip$t (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real average[npts] # Average +$else +PIXEL average[npts] # Average +$endif + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +$if (datatype == sil) +real d1, low, high, sum, a, s, r, one +data one /1.0/ +$else +PIXEL d1, low, high, sum, a, s, r, one +data one /1$f/ +$endif +pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Flag whether returned average needs to be recomputed. + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Save the residuals and the sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Do sigma clipping. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + + # If there are not enough pixels simply compute the average. + if (n1 < max (3, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mem$t[d[1]+k] + do j = 2, n1 + sum = sum + Mem$t[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + # Compute average with the high and low rejected. + low = Mem$t[d[1]+k] + high = Mem$t[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mem$t[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Iteratively reject pixels and compute the final average if needed. + # Compact the data and keep track of the image IDs if needed. + + repeat { + n2 = n1 + if (doscale1) { + # Compute sigma corrected for scaling. + s = 0. + wp = w - 1 + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Mem$t[dp1] + l = Memi[mp1] + r = sqrt (max (one, (a + zeros[l]) / scales[l])) + s = s + ((d1 - a) / r) ** 2 + Memr[wp] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + wp = w - 1 + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Mem$t[dp1] + r = (d1 - a) / (s * Memr[wp]) + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + Memr[wp] = Memr[w+n1-1] + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } else { + # Compute the sigma without scale correction. + s = 0. + do j = 1, n1 + s = s + (Mem$t[d[j]+k] - a) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Mem$t[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median + +procedure ic_msigclip$t (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real median[npts] # Median +$else +PIXEL median[npts] # Median +$endif + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, w, mp1, mp2 +$if (datatype == sil) +real med, one +data one /1.0/ +$else +PIXEL med, one +data one /1$f/ +$endif + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Save the residuals and sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = n[1] + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) + med = (Mem$t[d[n3-1]+k] + Mem$t[d[n3]+k]) / 2. + else + med = Mem$t[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + # Compute the sigma with scaling correction. + s = 0. + do j = nl, nh { + l = Memi[m[j]+k] + r = sqrt (max (one, (med + zeros[l]) / scales[l])) + s = s + ((Mem$t[d[j]+k] - med) / r) ** 2 + Memr[w+j-1] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= n2; nl = nl + 1) { + r = (med - Mem$t[d[nl]+k]) / (s * Memr[w+nl-1]) + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mem$t[d[nh]+k] - med) / (s * Memr[w+nh-1]) + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } else { + # Compute the sigma without scaling correction. + s = 0. + do j = nl, nh + s = s + (Mem$t[d[j]+k] - med) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= n2; nl = nl + 1) { + r = (med - Mem$t[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mem$t[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == n[i]) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (n[i] != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/icsection.x b/noao/twodspec/longslit/lscombine/src/icsection.x new file mode 100644 index 00000000..746c1f51 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icsection.x @@ -0,0 +1,94 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> + +# IC_SECTION -- Parse an image section into its elements. +# 1. The default values must be set by the caller. +# 2. A null image section is OK. +# 3. The first nonwhitespace character must be '['. +# 4. The last interpreted character must be ']'. +# +# This procedure should be replaced with an IMIO procedure at some +# point. + +procedure ic_section (section, x1, x2, xs, ndim) + +char section[ARB] # Image section +int x1[ndim] # Starting pixel +int x2[ndim] # Ending pixel +int xs[ndim] # Step +int ndim # Number of dimensions + +int i, ip, a, b, c, temp, ctoi() +define error_ 99 + +begin + # Decode the section string. + ip = 1 + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == '[') + ip = ip + 1 + else if (section[ip] == EOS) + return + else + goto error_ + + do i = 1, ndim { + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == ']') + break + + # Default values + a = x1[i] + b = x2[i] + c = xs[i] + + # 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 = temp + if (section[ip] == ':') { + ip = ip + 1 + if (ctoi (section, ip, b) == 0) # a:b + goto error_ + } else + b = a + } else if (section[ip] == '-') { # -* + temp = a + a = b + b = 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) == 0) + goto error_ + else if (c == 0) + goto error_ + } + if (a > b && c > 0) + c = -c + + x1[i] = a + x2[i] = b + xs[i] = c + + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == ',') + ip = ip + 1 + } + + if (section[ip] != ']') + goto error_ + + return +error_ + call error (0, "Error in image section specification") +end diff --git a/noao/twodspec/longslit/lscombine/src/icsetout.x b/noao/twodspec/longslit/lscombine/src/icsetout.x new file mode 100644 index 00000000..51e1fe90 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icsetout.x @@ -0,0 +1,322 @@ +include <imhdr.h> +include <imset.h> +include <mwset.h> + +define OFFTYPES "|none|wcs|world|physical|grid|" +define FILE 0 +define NONE 1 +define WCS 2 +define WORLD 3 +define PHYSICAL 4 +define GRID 5 + +# IC_SETOUT -- Set output image size and offsets of input images. + +procedure ic_setout (in, out, offsets, nimages) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int offsets[nimages,ARB] # Offsets +int nimages # Number of images + +int i, j, indim, outdim, mwdim, a, b, amin, bmax, fd, offtype +real val +bool proj, reloff, flip, streq(), fp_equald() +pointer sp, str, fname +pointer ltv, lref, wref, cd, ltm, coord, shift, axno, axval, section +pointer mw, ct, mw_openim(), mw_sctran(), xt_immap() +int open(), fscan(), nscan(), mw_stati(), strlen(), strdic() +errchk mw_openim, mw_gwtermd, mw_gltermd, mw_gaxmap +errchk mw_sctran, mw_ctrand, open, xt_immap + +include "icombine.com" +define newscan_ 10 + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (ltv, IM_MAXDIM, TY_DOUBLE) + call salloc (ltm, IM_MAXDIM*IM_MAXDIM, TY_DOUBLE) + call salloc (lref, IM_MAXDIM, TY_DOUBLE) + call salloc (wref, IM_MAXDIM, TY_DOUBLE) + call salloc (cd, IM_MAXDIM*IM_MAXDIM, TY_DOUBLE) + call salloc (coord, IM_MAXDIM, TY_DOUBLE) + call salloc (shift, IM_MAXDIM, TY_REAL) + call salloc (axno, IM_MAXDIM, TY_INT) + call salloc (axval, IM_MAXDIM, TY_INT) + + # Check and set the image dimensionality. + indim = IM_NDIM(in[1]) + outdim = IM_NDIM(out[1]) + proj = (indim != outdim) + if (!proj) { + do i = 1, nimages + if (IM_NDIM(in[i]) != outdim) { + call sfree (sp) + call error (1, "Image dimensions are not the same") + } + } + + # Set the reference point to that of the first image. + mw = mw_openim (in[1]) + call mw_seti (mw, MW_USEAXMAP, NO) + mwdim = mw_stati (mw, MW_NPHYSDIM) + call mw_gwtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) + ct = mw_sctran (mw, "world", "logical", 0) + call mw_ctrand (ct, Memd[wref], Memd[lref], mwdim) + call mw_ctfree (ct) + if (proj) + Memd[lref+outdim] = 1 + + # Parse the user offset string. If "none" then there are no offsets. + # If "world" or "wcs" then set the offsets based on the world WCS. + # If "physical" then set the offsets based on the physical WCS. + # If "grid" then set the offsets based on the input grid parameters. + # If a file scan it. + + call clgstr ("offsets", Memc[fname], SZ_FNAME) + call sscan (Memc[fname]) + call gargwrd (Memc[fname], SZ_FNAME) + if (nscan() == 0) + offtype = NONE + else { + offtype = strdic (Memc[fname], Memc[str], SZ_FNAME, OFFTYPES) + if (offtype > 0 && !streq (Memc[fname], Memc[str])) + offtype = 0 + } + if (offtype == 0) + offtype = FILE + + switch (offtype) { + case NONE: + call aclri (offsets, outdim*nimages) + reloff = true + case WORLD, WCS: + do j = 1, outdim + offsets[1,j] = 0 + if (proj) { + ct = mw_sctran (mw, "world", "logical", 0) + do i = 2, nimages { + Memd[wref+outdim] = i + call mw_ctrand (ct, Memd[wref], Memd[coord], indim) + do j = 1, outdim + offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) + } + call mw_ctfree (ct) + call mw_close (mw) + } else { + ct = mw_sctran (mw, "world", "logical", 0) + call mw_ctrand (ct, Memd[wref], Memd[lref], indim) + do i = 2, nimages { + call mw_close (mw) + mw = mw_openim (in[i]) + ct = mw_sctran (mw, "world", "logical", 0) + call mw_ctrand (ct, Memd[wref], Memd[coord], indim) + do j = 1, outdim + offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) + call mw_ctfree (ct) + } + } + reloff = true + case PHYSICAL: + call salloc (section, SZ_FNAME, TY_CHAR) + + call mw_gltermd (mw, Memd[ltm], Memd[coord], indim) + do i = 2, nimages { + call mw_close (mw) + mw = mw_openim (in[i]) + call mw_gltermd (mw, Memd[cd], Memd[coord], indim) + call strcpy ("[", Memc[section], SZ_FNAME) + flip = false + do j = 0, indim*indim-1, indim+1 { + if (Memd[ltm+j] * Memd[cd+j] >= 0.) + call strcat ("*,", Memc[section], SZ_FNAME) + else { + call strcat ("-*,", Memc[section], SZ_FNAME) + flip = true + } + } + Memc[section+strlen(Memc[section])-1] = ']' + if (flip) { + call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call strcat (Memc[section], Memc[fname], SZ_FNAME) + call xt_imunmap (in[i], i) + in[i] = xt_immap (Memc[fname], READ_ONLY, TY_CHAR, i) + call mw_close (mw) + mw = mw_openim (in[i]) + call mw_gltermd (mw, Memd[cd], Memd[coord], indim) + do j = 0, indim*indim-1 + if (!fp_equald (Memd[ltm+j], Memd[cd+j])) + call error (1, + "Cannot match physical coordinates") + } + } + + call mw_close (mw) + mw = mw_openim (in[1]) + ct = mw_sctran (mw, "logical", "physical", 0) + call mw_ctrand (ct, Memd[lref], Memd[ltv], indim) + call mw_ctfree (ct) + do j = 1, outdim + offsets[1,j] = 0 + if (proj) { + ct = mw_sctran (mw, "physical", "logical", 0) + do i = 2, nimages { + Memd[ltv+outdim] = i + call mw_ctrand (ct, Memd[ltv], Memd[coord], indim) + do j = 1, outdim + offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) + } + call mw_ctfree (ct) + call mw_close (mw) + } else { + do i = 2, nimages { + call mw_close (mw) + mw = mw_openim (in[i]) + ct = mw_sctran (mw, "physical", "logical", 0) + call mw_ctrand (ct, Memd[ltv], Memd[coord], indim) + do j = 1, outdim + offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) + call mw_ctfree (ct) + } + } + reloff = true + case GRID: + amin = 1 + do j = 1, outdim { + call gargi (a) + call gargi (b) + if (nscan() < 1+2*j) { + a = 1 + b = 0 + } + do i = 1, nimages + offsets[i,j] = mod ((i-1)/amin, a) * b + amin = amin * a + } + reloff = true + case FILE: + reloff = true + fd = open (Memc[fname], READ_ONLY, TEXT_FILE) + do i = 1, nimages { +newscan_ if (fscan (fd) == EOF) + call error (1, "IMCOMBINE: Offset list too short") + call gargwrd (Memc[fname], SZ_FNAME) + if (Memc[fname] == '#') { + call gargwrd (Memc[fname], SZ_FNAME) + call strlwr (Memc[fname]) + if (streq (Memc[fname], "absolute")) + reloff = false + else if (streq (Memc[fname], "relative")) + reloff = true + goto newscan_ + } + call reset_scan () + do j = 1, outdim { + call gargr (val) + offsets[i,j] = nint (val) + } + if (nscan() < outdim) + call error (1, "IMCOMBINE: Error in offset list") + } + call close (fd) + } + + # Set the output image size and the aligned flag + aligned = true + do j = 1, outdim { + a = offsets[1,j] + b = IM_LEN(in[1],j) + a + amin = a + bmax = b + do i = 2, nimages { + a = offsets[i,j] + b = IM_LEN(in[i],j) + a + if (a != amin || b != bmax || !reloff) + aligned = false + amin = min (a, amin) + bmax = max (b, bmax) + } + IM_LEN(out[1],j) = bmax + if (reloff || amin < 0) { + do i = 1, nimages + offsets[i,j] = offsets[i,j] - amin + IM_LEN(out[1],j) = IM_LEN(out[1],j) - amin + } + } + + # Get the output limits. + call clgstr ("outlimits", Memc[fname], SZ_FNAME) + call sscan (Memc[fname]) + do j = 1, outdim { + call gargi (a) + call gargi (b) + if (nscan() < 2*j) + break + if (!IS_INDEFI(a)) { + do i = 1, nimages { + offsets[i,j] = offsets[i,j] - a + 1 + if (offsets[i,j] != 0) + aligned = false + } + IM_LEN(out[1],j) = IM_LEN(out[1],j) - a + 1 + } + if (!IS_INDEFI(a) && !IS_INDEFI(b)) + IM_LEN(out[1],j) = min (IM_LEN(out[1],j), b - a + 1) + } + + # Update the WCS. + if (proj || !aligned || !reloff) { + call mw_close (mw) + mw = mw_openim (out[1]) + mwdim = mw_stati (mw, MW_NPHYSDIM) + call mw_gaxmap (mw, Memi[axno], Memi[axval], mwdim) + if (!aligned || !reloff) { + call mw_gltermd (mw, Memd[cd], Memd[lref], mwdim) + do i = 1, mwdim { + j = Memi[axno+i-1] + if (j > 0 && j <= indim) + Memd[lref+i-1] = Memd[lref+i-1] + offsets[1,j] + } + if (proj) + Memd[lref+mwdim-1] = 0. + call mw_sltermd (mw, Memd[cd], Memd[lref], mwdim) + } + if (proj) { + # Apply dimensional reduction. + do i = 1, mwdim { + j = Memi[axno+i-1] + if (j <= outdim) + next + else if (j > outdim+1) + Memi[axno+i-1] = j - 1 + else { + Memi[axno+i-1] = 0 + Memi[axval+i-1] = 0 + } + } + call mw_saxmap (mw, Memi[axno], Memi[axval], mwdim) + } + + # Reset physical coordinates. + if (offtype == WCS || offtype == WORLD) { + call mw_gltermd (mw, Memd[ltm], Memd[ltv], mwdim) + call mw_gwtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) + call mwvmuld (Memd[ltm], Memd[lref], Memd[lref], mwdim) + call aaddd (Memd[lref], Memd[ltv], Memd[lref], mwdim) + call mwinvertd (Memd[ltm], Memd[ltm], mwdim) + call mwmmuld (Memd[cd], Memd[ltm], Memd[cd], mwdim) + call mw_swtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) + call aclrd (Memd[ltv], mwdim) + call aclrd (Memd[ltm], mwdim*mwdim) + do i = 1, mwdim + Memd[ltm+(i-1)*(mwdim+1)] = 1. + call mw_sltermd (mw, Memd[ltm], Memd[ltv], mwdim) + } + call mw_saveim (mw, out) + } + call mw_close (mw) + + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lscombine/src/icsigma.gx b/noao/twodspec/longslit/lscombine/src/icsigma.gx new file mode 100644 index 00000000..1304d940 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icsigma.gx @@ -0,0 +1,122 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +$for (sird) +# IC_SIGMA -- Compute the sigma image line. +# The estimated sigma includes a correction for the finite population. +# Weights are used if desired. + +procedure ic_sigma$t (d, m, n, wts, npts, average, sigma) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +$if (datatype == sil) +real average[npts] # Average +real sigma[npts] # Sigma line (returned) +$else +PIXEL average[npts] # Average +PIXEL sigma[npts] # Sigma line (returned) +$endif + +int i, j, k, n1 +real wt, sigcor, sumwt +$if (datatype == sil) +real a, sum +$else +PIXEL a, sum +$endif + +include "../icombine.com" + +begin + if (dflag == D_ALL) { + n1 = n[1] + if (dowts) { + if (n1 > 1) + sigcor = real (n1) / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Mem$t[d[1]+k] - a) ** 2 * wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Mem$t[d[j]+k] - a) ** 2 * wt + } + sigma[i] = sqrt (sum * sigcor) + } + } else { + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + sum = (Mem$t[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mem$t[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } + } + } else if (dflag == D_NONE) { + do i = 1, npts + sigma[i] = blank + } else { + if (dowts) { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = real (n1) / real (n1 -1) + else + sigcor = 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Mem$t[d[1]+k] - a) ** 2 * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Mem$t[d[j]+k] - a) ** 2 * wt + sumwt = sumwt + wt + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Mem$t[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mem$t[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * sigcor) + } + } else + sigma[i] = blank + } + } else { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + a = average[i] + sum = (Mem$t[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mem$t[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } else + sigma[i] = blank + } + } + } +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/icsort.gx b/noao/twodspec/longslit/lscombine/src/icsort.gx new file mode 100644 index 00000000..e124da15 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icsort.gx @@ -0,0 +1,386 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +$for (sird) +# IC_SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. + +procedure ic_sort$t (a, b, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +PIXEL b[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +PIXEL pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix + b[i] = Mem$t[a[i]+l] + + # Special cases + $if (datatype == x) + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (abs (temp) < abs (pivot)) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (abs (temp) < abs (pivot)) { # bac|bca|cba + if (abs (temp) < abs (temp3)) { # bac|bca + b[1] = temp + if (abs (pivot) < abs (temp3)) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (abs (temp3) < abs (temp)) { # acb|cab + b[3] = temp + if (abs (pivot) < abs (temp3)) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + $else + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + $endif + + # General case + do i = 1, npix + b[i] = Mem$t[a[i]+l] + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + $if (datatype == x) + for (i=i+1; abs(b[i]) < abs(pivot); i=i+1) + $else + for (i=i+1; b[i] < pivot; i=i+1) + $endif + ; + for (j=j-1; j > i; j=j-1) + $if (datatype == x) + if (abs(b[j]) <= abs(pivot)) + $else + if (b[j] <= pivot) + $endif + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix + Mem$t[a[i]+l] = b[i] + } +end + + +# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. A second integer set of +# vectors is sorted. + +procedure ic_2sort$t (a, b, c, d, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +PIXEL b[ARB] # work array +pointer c[ARB] # pointer to associated integer vectors +int d[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +PIXEL pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp +define swap {temp=$1;$1=$2;$2=temp} +define iswap {itemp=$1;$1=$2;$2=itemp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix { + b[i] = Mem$t[a[i]+l] + d[i] = Memi[c[i]+l] + } + + # Special cases + $if (datatype == x) + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (abs (temp) < abs (pivot)) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (abs (temp) < abs (pivot)) { # bac|bca|cba + if (abs (temp) < abs (temp3)) { # bac|bca + b[1] = temp + if (abs (pivot) < abs (temp3)) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (abs (temp3) < abs (temp)) { # acb|cab + b[3] = temp + if (abs (pivot) < abs (temp3)) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + $else + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + $endif + + # General case + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]); swap (d[j], d[k]) + pivot = b[j] # pivot line + + while (i < j) { + $if (datatype == x) + for (i=i+1; abs(b[i]) < abs(pivot); i=i+1) + $else + for (i=i+1; b[i] < pivot; i=i+1) + $endif + ; + for (j=j-1; j > i; j=j-1) + $if (datatype == x) + if (abs(b[j]) <= abs(pivot)) + $else + if (b[j] <= pivot) + $endif + break + if (i < j) { # out of order pair + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + } + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix { + Mem$t[a[i]+l] = b[i] + Memi[c[i]+l] = d[i] + } + } +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/icstat.gx b/noao/twodspec/longslit/lscombine/src/icstat.gx new file mode 100644 index 00000000..c594182b --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/icstat.gx @@ -0,0 +1,238 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +define NMAX 100000 # Maximum number of pixels to sample + +$for (sird) +# IC_STAT -- Compute image statistics within specified section. +# The image section is relative to a reference image which may be +# different than the input image and may have an offset. Only a +# subsample of pixels is used. Masked and thresholded pixels are +# ignored. Only the desired statistics are computed to increase +# efficiency. + +procedure ic_stat$t (im, imref, section, offsets, image, nimages, + domode, domedian, domean, mode, median, mean) + +pointer im # Data image +pointer imref # Reference image for image section +char section[ARB] # Image section +int offsets[nimages,ARB] # Image section offset from data to reference +int image # Image index (for mask I/O) +int nimages # Number of images in offsets. +bool domode, domedian, domean # Statistics to compute +real mode, median, mean # Statistics + +int i, j, ndim, n, nv +real a +pointer sp, v1, v2, dv, va, vb +pointer data, mask, dp, lp, mp, imgnl$t() + +$if (datatype == csir) +real asum$t() +$else $if (datatype == ld) +double asum$t() +$else +PIXEL asum$t() +$endif $endif +PIXEL ic_mode$t() + +include "../icombine.com" + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (dv, IM_MAXDIM, TY_LONG) + call salloc (va, IM_MAXDIM, TY_LONG) + call salloc (vb, IM_MAXDIM, TY_LONG) + + # Determine the image section parameters. This must be in terms of + # the data image pixel coordinates though the section may be specified + # in terms of the reference image coordinates. Limit the number of + # pixels in each dimension to a maximum. + + ndim = IM_NDIM(im) + if (project) + ndim = ndim - 1 + call amovki (1, Memi[v1], IM_MAXDIM) + call amovki (1, Memi[va], IM_MAXDIM) + call amovki (1, Memi[dv], IM_MAXDIM) + call amovi (IM_LEN(imref,1), Memi[vb], ndim) + call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) + if (im != imref) + do i = 1, ndim { + Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] + Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] + } + + do j = 1, 10 { + n = 1 + do i = 0, ndim-1 { + Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) + Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) + Memi[dv+i] = j + nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] + n = n * nv + } + if (n < NMAX) + break + } + + call amovl (Memi[v1], Memi[va], IM_MAXDIM) + Memi[va] = 1 + if (project) + Memi[va+ndim] = image + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + + # Accumulate the pixel values within the section. Masked pixels and + # thresholded pixels are ignored. + + call salloc (data, n, TY_PIXEL) + dp = data + while (imgnl$t (im, lp, Memi[vb]) != EOF) { + call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) + lp = lp + Memi[v1] - 1 + if (dflag == D_ALL) { + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + a = Mem$t[lp] + if (a >= lthresh && a <= hthresh) { + Mem$t[dp] = a + dp = dp + 1 + } + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + Mem$t[dp] = Mem$t[lp] + dp = dp + 1 + lp = lp + Memi[dv] + } + } + } else if (dflag == D_MIX) { + mp = mask + Memi[v1] - 1 + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + a = Mem$t[lp] + if (a >= lthresh && a <= hthresh) { + Mem$t[dp] = a + dp = dp + 1 + } + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + Mem$t[dp] = Mem$t[lp] + dp = dp + 1 + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } + } + for (i=2; i<=ndim; i=i+1) { + Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] + if (Memi[va+i-1] <= Memi[v2+i-1]) + break + Memi[va+i-1] = Memi[v1+i-1] + } + if (i > ndim) + break + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + n = dp - data + if (n < 1) { + call sfree (sp) + call error (1, "Image section contains no pixels") + } + + # Compute only statistics needed. + if (domode || domedian) { + call asrt$t (Mem$t[data], Mem$t[data], n) + mode = ic_mode$t (Mem$t[data], n) + median = Mem$t[data+n/2-1] + } + if (domean) + mean = asum$t (Mem$t[data], n) / n + + call sfree (sp) +end + + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZRANGE 0.7 # Fraction of pixels about median to use +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + +# IC_MODE -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +PIXEL procedure ic_mode$t (a, n) + +PIXEL a[n] # Data array +int n # Number of points + +int i, j, k, nmax +real z1, z2, zstep, zbin +PIXEL mode +bool fp_equalr() + +begin + if (n < NMIN) + return (a[n/2]) + + # Compute the mode. The array must be sorted. Consider a + # range of values about the median point. Use a bin size which + # is ZBIN of the range. Step the bin limits in ZSTEP fraction of + # the bin size. + + i = 1 + n * (1. - ZRANGE) / 2. + j = 1 + n * (1. + ZRANGE) / 2. + z1 = a[i] + z2 = a[j] + if (fp_equalr (z1, z2)) { + mode = z1 + return (mode) + } + + zstep = ZSTEP * (z2 - z1) + zbin = ZBIN * (z2 - z1) + $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 && a[i] < z1; i=i+1) + ; + for (; k < j && a[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = a[(i+k)/2] + } + } until (k >= j) + + return (mode) +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/mkpkg b/noao/twodspec/longslit/lscombine/src/mkpkg new file mode 100644 index 00000000..2ed3d8cb --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/mkpkg @@ -0,0 +1,62 @@ + Make the IMCOMBINE Task. + +$checkout libpkg.a ../../../../ +$update libpkg.a +$checkin libpkg.a ../../../../ +$exit + +generic: + $set GEN = "$$generic -k" + + $ifolder (generic/icaclip.x, icaclip.gx) + $(GEN) icaclip.gx -o generic/icaclip.x $endif + $ifolder (generic/icaverage.x, icaverage.gx) + $(GEN) icaverage.gx -o generic/icaverage.x $endif + $ifolder (generic/iccclip.x, iccclip.gx) + $(GEN) iccclip.gx -o generic/iccclip.x $endif + $ifolder (generic/icgdata.x, icgdata.gx) + $(GEN) icgdata.gx -o generic/icgdata.x $endif + $ifolder (generic/icgrow.x, icgrow.gx) + $(GEN) icgrow.gx -o generic/icgrow.x $endif + $ifolder (generic/icmedian.x, icmedian.gx) + $(GEN) icmedian.gx -o generic/icmedian.x $endif + $ifolder (generic/icmm.x, icmm.gx) + $(GEN) icmm.gx -o generic/icmm.x $endif + $ifolder (generic/icomb.x, icomb.gx) + $(GEN) icomb.gx -o generic/icomb.x $endif + $ifolder (generic/icpclip.x, icpclip.gx) + $(GEN) icpclip.gx -o generic/icpclip.x $endif + $ifolder (generic/icsclip.x, icsclip.gx) + $(GEN) icsclip.gx -o generic/icsclip.x $endif + $ifolder (generic/icsigma.x, icsigma.gx) + $(GEN) icsigma.gx -o generic/icsigma.x $endif + $ifolder (generic/icsort.x, icsort.gx) + $(GEN) icsort.gx -o generic/icsort.x $endif + $ifolder (generic/icstat.x, icstat.gx) + $(GEN) icstat.gx -o generic/icstat.x $endif + + $ifolder (generic/xtimmap.x, xtimmap.gx) + $(GEN) xtimmap.gx -o generic/xtimmap.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + @generic + + icemask.x <imhdr.h> <mach.h> + icgscale.x icombine.com icombine.h + ichdr.x <imset.h> + icimstack.x <error.h> <imhdr.h> + iclog.x icmask.h icombine.com icombine.h <imhdr.h> <imset.h>\ + <mach.h> + icmask.x icmask.h icombine.com icombine.h <imhdr.h> <pmset.h> + icombine.x icombine.com icombine.h <error.h> <imhdr.h> <imset.h> + icpmmap.x <pmset.h> + icrmasks.x <imhdr.h> + icscale.x icombine.com icombine.h <imhdr.h> <imset.h> + icsection.x <ctype.h> + icsetout.x icombine.com <imhdr.h> <imset.h> <mwset.h> + tymax.x <mach.h> + xtprocid.x + ; diff --git a/noao/twodspec/longslit/lscombine/src/tymax.x b/noao/twodspec/longslit/lscombine/src/tymax.x new file mode 100644 index 00000000..a7f4f469 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/tymax.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + + +# TY_MAX -- Return the datatype of highest precedence. + +int procedure ty_max (type1, type2) + +int type1, type2 # Datatypes + +int i, j, type, order[8] +data order/TY_SHORT,TY_USHORT,TY_INT,TY_LONG,TY_REAL,TY_DOUBLE,TY_COMPLEX,TY_REAL/ + +begin + for (i=1; (i<=7) && (type1!=order[i]); i=i+1) + ; + for (j=1; (j<=7) && (type2!=order[j]); j=j+1) + ; + type = order[max(i,j)] + + # Special case of mixing short and unsigned short. + if (type == TY_USHORT && type1 != type2) + type = TY_INT + + return (type) +end diff --git a/noao/twodspec/longslit/lscombine/src/xtimmap.com b/noao/twodspec/longslit/lscombine/src/xtimmap.com new file mode 100644 index 00000000..61bf314a --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/xtimmap.com @@ -0,0 +1,8 @@ +int option +int nopen +int nopenpix +int nalloc +int last_flag +int min_open +pointer ims +common /xtimmapcom/ option, ims, nopen, nopenpix, nalloc, last_flag, min_open diff --git a/noao/twodspec/longslit/lscombine/src/xtimmap.gx b/noao/twodspec/longslit/lscombine/src/xtimmap.gx new file mode 100644 index 00000000..c0ae26a6 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/xtimmap.gx @@ -0,0 +1,552 @@ +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imset.h> +include <config.h> + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include <imset.h> + +# These routines maintain an arbitrary number of indexed "open" images which +# must be READ_ONLY. The calling program may use the returned pointer for +# header accesses but must call xt_opix before I/O. Subsequent calls to +# xt_opix may invalidate the pointer. The xt_imunmap call will free memory. + +define MAX_OPENIM (LAST_FD-16) # Maximum images kept open +define MAX_OPENPIX 45 # Maximum pixel files kept open + +define XT_SZIMNAME 299 # Size of IMNAME string +define XT_LEN 179 # Structure length +define XT_IMNAME Memc[P2C($1)] # Image name +define XT_ARG Memi[$1+150] # IMMAP header argument +define XT_IM Memi[$1+151] # IMIO pointer +define XT_HDR Memi[$1+152] # Copy of IMIO pointer +define XT_CLOSEFD Memi[$1+153] # Close FD? +define XT_FLAG Memi[$1+154] # Flag +define XT_BUFSIZE Memi[$1+155] # Buffer size +define XT_BUF Memi[$1+156] # Data buffer +define XT_BTYPE Memi[$1+157] # Data buffer type +define XT_VS Memi[$1+157+$2] # Start vector (10) +define XT_VE Memi[$1+167+$2] # End vector (10) + +# Options +define XT_MAPUNMAP 1 # Map and unmap images. + +# XT_IMMAP -- Map an image and save it as an indexed open image. +# The returned pointer may be used for header access but not I/O. +# The indexed image is closed by xt_imunmap. + +pointer procedure xt_immap (imname, acmode, hdr_arg, index) + +char imname[ARB] #I Image name +int acmode #I Access mode +int hdr_arg #I Header argument +int index #I Save index +pointer im #O Image pointer (returned) + +int i, envgeti() +pointer xt, xt_opix() +errchk xt_opix + +int first_time +data first_time /YES/ + +include "../xtimmap.com" + +begin + if (acmode != READ_ONLY) + call error (1, "XT_IMMAP: Only READ_ONLY allowed") + + # Initialize once per process. + if (first_time == YES) { + iferr (option = envgeti ("imcombine_option")) + option = 1 + min_open = 1 + nopen = 0 + nopenpix = 0 + nalloc = MAX_OPENIM + call calloc (ims, nalloc, TY_POINTER) + first_time = NO + } + + # Free image if needed. + call xt_imunmap (NULL, index) + + # Allocate structure. + if (index > nalloc) { + i = nalloc + nalloc = index + MAX_OPENIM + call realloc (ims, nalloc, TY_STRUCT) + call amovki (NULL, Memi[ims+i], nalloc-i) + } + call calloc (xt, XT_LEN, TY_STRUCT) + Memi[ims+index-1] = xt + + # Initialize. + call strcpy (imname, XT_IMNAME(xt), XT_SZIMNAME) + XT_ARG(xt) = hdr_arg + XT_IM(xt) = NULL + XT_HDR(xt) = NULL + + # Open image. + last_flag = 0 + im = xt_opix (NULL, index, 0) + + # Make copy of IMIO pointer for header keyword access. + call malloc (XT_HDR(xt), LEN_IMDES+IM_HDRLEN(im)+1, TY_STRUCT) + call amovi (Memi[im], Memi[XT_HDR(xt)], LEN_IMDES) + call amovi (IM_MAGIC(im), IM_MAGIC(XT_HDR(xt)), IM_HDRLEN(im)+1) + + return (XT_HDR(xt)) +end + + +# XT_OPIX -- Open the image for I/O. +# If the image has not been mapped return the default pointer. + +pointer procedure xt_opix (imdef, index, flag) + +int index #I index +pointer imdef #I Default pointer +int flag #I Flag + +int i, open(), imstati() +pointer im, xt, xt1, immap() +errchk open, immap, imunmap + +include "../xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imdef) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Return pointer for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (im) + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= MAX_OPENIM) { + if (option == XT_MAPUNMAP || flag == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + if (!IS_INDEFI(XT_BUFSIZE(xt))) + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + else + XT_BUFSIZE(xt) = imstati (im, IM_BUFSIZE) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (im) +end + + +# XT_CPIX -- Close image. + +procedure xt_cpix (index) + +int index #I index + +pointer xt +errchk imunmap + +include "../xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) + return + + if (XT_IM(xt) != NULL) { + call imunmap (XT_IM(xt)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + } + call mfree (XT_BUF(xt), XT_BTYPE(xt)) +end + + +# XT_IMSETI -- Set IMIO value. + +procedure xt_imseti (index, param, value) + +int index #I index +int param #I IMSET parameter +int value #I Value + +pointer xt +bool streq() + +include "../xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) { + if (streq (param, "option")) + option = value + } else { + if (streq (param, "bufsize")) { + XT_BUFSIZE(xt) = value + if (XT_IM(xt) != NULL) { + call imseti (XT_IM(xt), IM_BUFFRAC, 0) + call imseti (XT_IM(xt), IM_BUFSIZE, value) + } + } + } +end + + +# XT_IMUNMAP -- Unmap indexed open image. +# The header pointer is set to NULL to indicate the image has been closed. + +procedure xt_imunmap (im, index) + +int im #U IMIO header pointer +int index #I index + +pointer xt +errchk imunmap + +include "../xtimmap.com" + +begin + # Check for an indexed image. If it is not unmap the pointer + # as a regular IMIO pointer. + + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + if (xt == NULL) { + if (im != NULL) + call imunmap (im) + return + } + + # Close indexed image. + if (XT_IM(xt) != NULL) { + iferr (call imunmap (XT_IM(xt))) { + XT_IM(xt) = NULL + call erract (EA_WARN) + } + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + if (index == min_open) + min_open = 1 + } + + # Free any buffered memory. + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + + # Free header pointer. Note that if the supplied pointer is not + # header pointer then it is not set to NULL. + if (XT_HDR(xt) == im) + im = NULL + call mfree (XT_HDR(xt), TY_STRUCT) + + # Free save structure. + call mfree (Memi[ims+index-1], TY_STRUCT) + Memi[ims+index-1] = NULL +end + + +# XT_REINDEX -- Reindex open images. +# This is used when some images are closed by xt_imunmap. It is up to +# the calling program to reindex the header pointers and to subsequently +# use the new index values. + +procedure xt_reindex () + +int old, new + +include "../xtimmap.com" + +begin + new = 0 + do old = 0, nalloc-1 { + if (Memi[ims+old] == NULL) + next + Memi[ims+new] = Memi[ims+old] + new = new + 1 + } + do old = new, nalloc-1 + Memi[ims+old] = NULL +end + + +$for(sird) +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnl$t (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnl$t(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggs$t() +errchk open, immap, imgnl$t, imggs$t, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "../xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnl$t (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnl$t (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_PIXEL) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= MAX_OPENIM) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_PIXEL) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_PIXEL + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggs$t (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amov$t (Mem$t[ptr], Mem$t[XT_BUF(xt1)], nl*nc) + } + + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnl$t (im, buf, v)) +end +$endfor diff --git a/noao/twodspec/longslit/lscombine/src/xtprocid.x b/noao/twodspec/longslit/lscombine/src/xtprocid.x new file mode 100644 index 00000000..0a82d81b --- /dev/null +++ b/noao/twodspec/longslit/lscombine/src/xtprocid.x @@ -0,0 +1,38 @@ +# XT_PROCID -- Set or ppdate PROCID keyword. + +procedure xt_procid (im) + +pointer im #I Image header + +int i, j, ver, patmake(), gpatmatch(), strlen(), ctoi() +pointer sp, pat, str + +begin + call smark (sp) + call salloc (pat, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get current ID. + iferr (call imgstr (im, "PROCID", Memc[str], SZ_LINE)) { + iferr (call imgstr (im, "OBSID", Memc[str], SZ_LINE)) { + call sfree (sp) + return + } + } + + # Set new PROCID. + ver = 0 + i = patmake ("V[0-9]*$", Memc[pat], SZ_LINE) + if (gpatmatch (Memc[str], Memc[pat], i, j) == 0) + ; + if (j > 0) { + j = i+1 + if (ctoi (Memc[str], j, ver) == 0) + ver = 0 + i = i - 1 + } else + i = strlen (Memc[str]) + call sprintf (Memc[str+i], SZ_LINE, "V%d") + call pargi (ver+1) + call imastr (im, "PROCID", Memc[str]) +end diff --git a/noao/twodspec/longslit/lscombine/t_lscombine.x b/noao/twodspec/longslit/lscombine/t_lscombine.x new file mode 100644 index 00000000..20fa2ef1 --- /dev/null +++ b/noao/twodspec/longslit/lscombine/t_lscombine.x @@ -0,0 +1,593 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <mach.h> +include <imhdr.h> +include "src/icombine.h" + + +# T_LSCOMBINE - This task combines a list of images into an output image +# and optional associated images and mask. There are many combining options +# from which to choose. +# +# This is a variant of IMCOMBINE that combines longslit spectra matched in +# world coordinates. The spectral images are first resampled to a common +# grid of pixels in temporary images and then combined, after which the +# temporary images are deleted. + +procedure t_lscombine () + +pointer sp, fname, output, headers, bmask, rmask, sigma, nrmask, emask, logfile +pointer scales, zeros, wts, im +int n, input, ilist, olist, hlist, blist, rlist, slist, nrlist, elist +int input1, mask1, delete + +bool clgetb() +real clgetr() +int clgwrd(), clgeti(), imtopenp(), imtopen(), imtgetim(), imtlen() +pointer immap() +errchk immap, icombine, lsc_transform + +include "src/icombine.com" + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (headers, SZ_FNAME, TY_CHAR) + call salloc (bmask, SZ_FNAME, TY_CHAR) + call salloc (rmask, SZ_FNAME, TY_CHAR) + call salloc (nrmask, SZ_FNAME, TY_CHAR) + call salloc (emask, SZ_FNAME, TY_CHAR) + call salloc (sigma, SZ_FNAME, TY_CHAR) + call salloc (ictask, SZ_FNAME, TY_CHAR) + call salloc (expkeyword, SZ_FNAME, TY_CHAR) + call salloc (statsec, SZ_FNAME, TY_CHAR) + call salloc (gain, SZ_FNAME, TY_CHAR) + call salloc (rdnoise, SZ_FNAME, TY_CHAR) + call salloc (snoise, SZ_FNAME, TY_CHAR) + call salloc (logfile, SZ_FNAME, TY_CHAR) + + # Get task parameters. Some additional parameters are obtained later. + call strcpy ("LSCOMBINE", Memc[ictask], SZ_FNAME) + ilist = imtopenp ("input") + olist = imtopenp ("output") + hlist = imtopenp ("headers") + blist = imtopenp ("bpmasks") + rlist = imtopenp ("rejmasks") + nrlist = imtopenp ("nrejmasks") + elist = imtopenp ("expmasks") + slist = imtopenp ("sigmas") + call clgstr ("logfile", Memc[logfile], SZ_FNAME) + + #project = clgetb ("project") + project = false + combine = clgwrd ("combine", Memc[fname], SZ_FNAME, COMBINE) + reject = clgwrd ("reject", Memc[fname], SZ_FNAME, REJECT) + blank = clgetr ("blank") + call clgstr ("expname", Memc[expkeyword], SZ_FNAME) + call clgstr ("statsec", Memc[statsec], SZ_FNAME) + call clgstr ("gain", Memc[gain], SZ_FNAME) + call clgstr ("rdnoise", Memc[rdnoise], SZ_FNAME) + call clgstr ("snoise", Memc[snoise], SZ_FNAME) + lthresh = clgetr ("lthreshold") + hthresh = clgetr ("hthreshold") + lsigma = clgetr ("lsigma") + hsigma = clgetr ("hsigma") + pclip = clgetr ("pclip") + flow = clgetr ("nlow") + fhigh = clgetr ("nhigh") + nkeep = clgeti ("nkeep") + grow = clgetr ("grow") + mclip = clgetb ("mclip") + sigscale = clgetr ("sigscale") + verbose = false + + # Check lists. + n = imtlen (ilist) + if (n == 0) + call error (1, "No input images to combine") + + if (project) { + if (imtlen (olist) != n) + call error (1, "Wrong number of output images") + if (imtlen (hlist) != 0 && imtlen (hlist) != n) + call error (1, "Wrong number of header files") + if (imtlen (blist) != 0 && imtlen (blist) != n) + call error (1, "Wrong number of bad pixel masks") + if (imtlen (rlist) != 0 && imtlen (rlist) != n) + call error (1, "Wrong number of rejection masks") + if (imtlen (nrlist) > 0 && imtlen (nrlist) != n) + call error (1, "Wrong number of number rejected masks") + if (imtlen (elist) > 0 && imtlen (elist) != n) + call error (1, "Wrong number of exposure masks") + if (imtlen (slist) > 0 && imtlen (slist) != n) + call error (1, "Wrong number of sigma images") + } else { + if (imtlen (olist) != 1) + call error (1, "Wrong number of output images") + if (imtlen (hlist) > 1) + call error (1, "Wrong number of header files") + if (imtlen (blist) > 1) + call error (1, "Wrong number of bad pixel masks") + if (imtlen (rlist) > 1) + call error (1, "Wrong number of rejection masks") + if (imtlen (nrlist) > 1) + call error (1, "Wrong number of number rejected masks") + if (imtlen (elist) > 1) + call error (1, "Wrong number of exposure masks") + if (imtlen (slist) > 1) + call error (1, "Wrong number of sigma images") + } + + # Check parameters, map INDEFs, and set threshold flag + if (pclip == 0. && reject == PCLIP) + call error (1, "Pclip parameter may not be zero") + if (IS_INDEFR (blank)) + blank = 0. + if (IS_INDEFR (lsigma)) + lsigma = MAX_REAL + if (IS_INDEFR (hsigma)) + hsigma = MAX_REAL + if (IS_INDEFR (pclip)) + pclip = -0.5 + if (IS_INDEFR (flow)) + flow = 0 + if (IS_INDEFR (fhigh)) + fhigh = 0 + if (IS_INDEFR (grow)) + grow = 0. + if (IS_INDEF (sigscale)) + sigscale = 0. + + if (IS_INDEF(lthresh) && IS_INDEF(hthresh)) + dothresh = false + else { + dothresh = true + if (IS_INDEF(lthresh)) + lthresh = -MAX_REAL + if (IS_INDEF(hthresh)) + hthresh = MAX_REAL + } + + # Loop through image lists. + while (imtgetim (ilist, Memc[fname], SZ_FNAME) != EOF) { + iferr { + scales = NULL; input = ilist; input1 = NULL; mask1 = NULL + + if (imtgetim (olist, Memc[output], SZ_FNAME) == EOF) { + if (project) { + call sprintf (Memc[output], SZ_FNAME, + "LSCOMBINE: No output image for %s") + call pargstr (Memc[fname]) + call error (1, Memc[output]) + } else + call error (1, "LSCOMBINE: No output image") + } + if (imtgetim (hlist, Memc[headers], SZ_FNAME) == EOF) + Memc[headers] = EOS + if (imtgetim (blist, Memc[bmask], SZ_FNAME) == EOF) + Memc[bmask] = EOS + if (imtgetim (rlist, Memc[rmask], SZ_FNAME) == EOF) + Memc[rmask] = EOS + if (imtgetim (nrlist, Memc[nrmask], SZ_FNAME) == EOF) + Memc[nrmask] = EOS + if (imtgetim (elist, Memc[emask], SZ_FNAME) == EOF) + Memc[emask] = EOS + if (imtgetim (slist, Memc[sigma], SZ_FNAME) == EOF) + Memc[sigma] = EOS + + # Set the input list and initialize the scaling factors. + if (project) { + im = immap (Memc[fname], READ_ONLY, 0) + if (IM_NDIM(im) == 1) + n = 0 + else + n = IM_LEN(im,IM_NDIM(im)) + call imunmap (im) + if (n == 0) { + call sprintf (Memc[output], SZ_FNAME, + "LSCOMBINE: Can't project one dimensional image %s") + call pargstr (Memc[fname]) + call error (1, Memc[output]) + } + input = imtopen (Memc[fname]) + } else { + call imtrew (ilist) + n = imtlen (ilist) + input = ilist + } + + # Allocate and initialize scaling factors. + call malloc (scales, 3*n, TY_REAL) + zeros = scales + n + wts = scales + 2 * n + call amovkr (INDEFR, Memr[scales], 3*n) + + # Register the images. + call lsc_transform (input, input1, mask1) + + # Set special values for LSCOMBINE application. + dothresh = true + if (IS_INDEF(lthresh)) + lthresh = -MAX_REAL + if (IS_INDEF(hthresh)) + hthresh = MAX_REAL + lthresh = max (-MAX_REAL * 0.999, lthresh) + + # Combine and then delete the temporary transformed images. + call icombine (input1, Memc[output], Memc[headers], Memc[bmask], + Memc[rmask], Memc[nrmask], Memc[emask], Memc[sigma], + Memc[logfile], Memr[scales], Memr[zeros], Memr[wts], NO, + delete) + + # Delete temporary files. + if (input1 != input) { + call imtrew (input1) + while (imtgetim (input1, Memc[fname], SZ_FNAME) != EOF) + iferr (call imdelete (Memc[fname])) + ; + while (imtgetim (mask1, Memc[fname], SZ_FNAME) != EOF) + iferr (call imdelete (Memc[fname])) + ; + } + + } then + call erract (EA_WARN) + + if (input1 != NULL && input1 != input) + call imtclose (input1) + if (mask1 != NULL) + call imtclose (mask1) + if (input != ilist) + call imtclose (input) + call mfree (scales, TY_REAL) + if (!project) + break + } + + call imtclose (ilist) + call imtclose (olist) + call imtclose (hlist) + call imtclose (blist) + call imtclose (rlist) + call imtclose (nrlist) + call imtclose (elist) + call imtclose (slist) + call sfree (sp) +end + + +include <math/iminterp.h> + + +# LSC_TRANSFORM -- Transform list of spectra to a matching coordinate system. +# The routine uses additional task parameters to specify the desired +# coordinate system. + +procedure lsc_transform (input, output, masks) + +pointer input #I List of input spectra +pointer output #O List of transformed spectra +pointer masks #O List of masks + +bool dotransform +int i, j, n, err, nwa[2], nw[2], nusf, nvsf, mtype +real w1a[2], w2a[2], dwa[2], w1[2], w2[2], dw[2], aux +pointer sp, inname, outname, minname, moutname, tmp +pointer w1s[2], w2s[2], dws[2], nws[2], linear[2] +pointer in, out, pmin, pmout, mw, ct, ptr +pointer un[2], usf, vsf, xmsi, ymsi, jmsi, xout, yout, dxout, dyout + +bool streq() +int clgeti(), clgwrd(), errget() +int imtopen(), imtgetim(), imtrgetim(), imtlen() +real clgetr() +real mw_c1tranr() +pointer immap(), mw_openim(), mw_sctran(), yt_mappm() +errchk immap, mw_openim, mw_sctran, yt_mappm + +include "../transform/transform.com" + +begin + + n = imtlen (input) + + call smark (sp) + call salloc (inname, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + call salloc (minname, SZ_FNAME, TY_CHAR) + call salloc (moutname, SZ_FNAME, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + do j = 1, 2 { + call salloc (w1s[j], n, TY_REAL) + call salloc (w2s[j], n, TY_REAL) + call salloc (dws[j], n, TY_REAL) + call salloc (nws[j], n, TY_INT) + call salloc (linear[j], n, TY_INT) + } + + # Get/set parameters. These are similar to TRANSFORM. + itype = clgwrd ("interptype", Memc[inname], SZ_FNAME, II_BFUNCTIONS) + u1 = clgetr ("x1"); u2 = clgetr ("x2"); + du = clgetr ("dx"); nu = clgeti ("nx") + v1 = clgetr ("y1"); v2 = clgetr ("y2") + dv = clgetr ("dy"); nv = clgeti ("ny") + ulog = false; vlog = false + flux = true + blank = -MAX_REAL + usewcs = true + + # The mask is only generated if the COMBINE parameter masktype is set. + mtype = clgwrd ("masktype", Memc[tmp], SZ_FNAME, "|none|goodvalue|") + + err = 0; dotransform = false + iferr { + in = NULL; pmin = NULL; out = NULL; pmout = NULL; mw= NULL + + # Get the linear WCS (or approximation) for each input. + # We get them all first since we need to compute a global + # WCS for the final combined spectrm. + + do i = 0, n-1 { + if (imtrgetim (input, i+1, Memc[inname], SZ_FNAME) == EOF) + call error (1, "Premature end of input list") + ptr = immap (Memc[inname], READ_ONLY, 0); in = ptr + ptr = mw_openim (in); mw = ptr + do j = 1, 2 { + ct = mw_sctran (mw, "logical", "world", j) + Memi[nws[j]+i] = IM_LEN(in,j) + Memr[w1s[j]+i] = mw_c1tranr (ct, 1.) + Memr[w2s[j]+i] = mw_c1tranr (ct, real(Memi[nws[j]+i])) + Memr[dws[j]+i] = (Memr[w2s[j]+i] - Memr[w1s[j]+i]) / + (Memi[nws[j]+i] - 1) + call mw_ctfree (ct) + call mw_gwattrs (mw, j, "wtype", Memc[outname], SZ_FNAME) + if (streq (Memc[outname], "linear")) + Memi[linear[j]+i] = YES + else + Memi[linear[j]+i] = NO + } + call mw_close (mw) + call imunmap (in) + } + + # Set the linear WCS for each axis. The follow sets values for + # those elements specified by the users as INDEF. + + w1a[1] = u1; w2a[1] = u2; dwa[1] = du; nwa[1] = nu + w1a[2] = v1; w2a[2] = v2; dwa[2] = dv; nwa[2] = nv + do j = 1, 2 { + w1[j] = w1a[j]; w2[j] = w2a[j]; dw[j] = dwa[j]; nw[j] = nwa[j] + + # Starting value. + if (IS_INDEFR(w1[j])) { + if (IS_INDEFR(dw[j]) || dw[j] > 0.) { + w1[j] = MAX_REAL + do i = 0, n-1 { + if (Memr[dws[j]+i] > 0.) + aux = Memr[w1s[j]+i] + else + aux = Memr[w2s[j]+i] + if (aux < w1[j]) + w1[j] = aux + } + } else { + w1[j] = -MAX_REAL + do i = 0, n-1 { + if (Memr[dws[j]+i] > 0.) + aux = Memr[w2s[j]+i] + else + aux = Memr[w1s[j]+i] + if (aux > w1[j]) + w1[j] = aux + } + } + } + + # Ending value. + if (IS_INDEFR(w2[j])) { + if (IS_INDEFR(dw[j]) || dw[j] > 0.) { + w2[j] = -MAX_REAL + do i = 0, n-1 { + if (Memr[dws[j]+i] > 0.) + aux = Memr[w2s[j]+i] + else + aux = Memr[w1s[j]+i] + if (aux > w2[j]) + w2[j] = aux + } + } else { + w2[j] = MAX_REAL + do i = 0, n-1 { + if (Memr[dws[j]+i] > 0.) + aux = Memr[w1s[j]+i] + else + aux = Memr[w2s[j]+i] + if (aux < w2[j]) + w2[j] = aux + } + } + } + + # Increment. + if (IS_INDEFR(dw[j])) { + dw[j] = MAX_REAL + do i = 0, n-1 { + aux = abs (Memr[dws[j]+i]) + if (aux < dw[j]) + dw[j] = aux + } + } + if ((w2[j] - w1[j]) / dw[j] < 0.) + dw[j] = -dw[j] + + # Number of pixels. + if (IS_INDEFI(nw[j])) + nw[j] = int ((w2[j] - w1[j]) / dw[j] + 0.5) + 1 + + # Adjust the values. + if (IS_INDEFR(dwa[j])) + dw[j] = (w2[j] - w1[j]) / (nw[j] - 1) + else if (IS_INDEFR(w2a[j])) + w2[j] = w1[j] + (nw[j] - 1) * dw[j] + else if (IS_INDEFR(w1a[j])) + w1[j] = w2[j] - (nw[j] - 1) * dw[j] + else { + nw[j] = int ((w2[j] - w1[j]) / dw[j] + 0.5) + 1 + w2[j] = w1[j] + (nw[j] - 1) * dw[j] + } + } + + # Check if the images need to be transformed. If all the + # input are already in the desired system then we don't need + # to need to transform. But if even one needs to be transformed + # we transform all of them. This is not ideal but it simplifies + # the code for now. + + do i = 0, n-1 { + do j = 1, 2 { + if (Memi[linear[j]+i] != YES) + dotransform = true + if (Memr[w1s[j]+i] != w1[j]) + dotransform = true + if (Memr[w2s[j]+i] != w2[j]) + dotransform = true + if (Memr[dws[j]+i] != dw[j]) + dotransform = true + if (dotransform) + break + } + if (dotransform) + break + } + + # Transform the images if needed. + if (dotransform) { + u1 = w1[1]; u2 = w2[1]; du = dw[1]; nu = nw[1] + v1 = w1[2]; v2 = w2[2]; dv = dw[2]; nv = nw[2] + call mktemp ("lsc", Memc[tmp], SZ_FNAME) + do i = 0, n-1 { + # Get the input name. + if (imtrgetim (input, i+1, Memc[inname], SZ_FNAME) == EOF) + call error (1, "Premature end of input list") + + # Map the input, output, and WCS. + ptr = immap (Memc[inname], READ_ONLY, 0); in = ptr + ptr = mw_openim (in); mw = ptr + call sprintf (Memc[outname], SZ_FNAME, "%s%d") + call pargstr (Memc[tmp]) + call pargi (i) + ptr = immap (Memc[outname], NEW_COPY, in); out = ptr + call imastr (out, "ICFNAME", Memc[inname]) + + # Set masks. + if (mtype > 1) { + ptr = yt_mappm ("BPM", in,"logical", Memc[minname], + SZ_FNAME) + pmin = ptr + if (pmin != NULL) { + call sprintf (Memc[moutname], SZ_FNAME, "m%s%d.pl") + call pargstr (Memc[tmp]) + call pargi (i) + call xt_maskname (Memc[moutname], "", NEW_IMAGE, + Memc[moutname], SZ_FNAME) + ptr = immap (Memc[moutname], NEW_COPY, in) + pmout = ptr + call imastr (out, "BPM", Memc[moutname]) + call imastr (pmout, "ICBPM", Memc[minname]) + } + } + + # Use the TRANSFORM routines. + call tr_gwcs (mw, un, IM_LEN(in,1), IM_LEN(in,2), ct, + usf, nusf, vsf, nvsf) + call tr_setup (ct, usf, nusf, vsf, nvsf, un, xmsi, ymsi, + jmsi, xout, yout, dxout, dyout) + + call tr_transform (in, out, pmin, pmout, un, xmsi, ymsi, + jmsi, Memr[xout], Memr[yout], Memr[dxout], Memr[dyout]) + + # Finish up. + call mw_close (mw) + if (pmout != NULL) + call imunmap (pmout) + if (pmin != NULL) + call xt_pmunmap (pmin) + call imunmap (out) + call imunmap (in) + call mfree (xout, TY_REAL) + call mfree (yout, TY_REAL) + call mfree (dxout, TY_REAL) + call mfree (dyout, TY_REAL) + call msifree (xmsi) + call msifree (ymsi) + if (jmsi != NULL) + call msifree (jmsi) + if (un[1] != NULL) + call un_close (un[1]) + if (un[2] != NULL) + call un_close (un[2]) + } + } + + } then { + # Save error for later reporting after cleaning up. + err = errget (Memc[inname], SZ_FNAME) + + if (mw != NULL) + call mw_close (mw) + if (pmout != NULL) + call imunmap (pmout) + if (pmin != NULL) + call xt_pmunmap (pmin) + if (out != NULL) + call imunmap (out) + if (in != NULL) + call imunmap (in) + call mfree (xout, TY_REAL) + call mfree (yout, TY_REAL) + call mfree (dxout, TY_REAL) + call mfree (dyout, TY_REAL) + if (xmsi != NULL) + call msifree (xmsi) + if (ymsi != NULL) + call msifree (ymsi) + if (jmsi != NULL) + call msifree (jmsi) + if (un[1] != NULL) + call un_close (un[1]) + if (un[2] != NULL) + call un_close (un[2]) + + # Open the temporary list, delete any found, and report err. + call sprintf (Memc[outname], SZ_FNAME, "%s*,m%s*.pl") + call pargstr (Memc[tmp]) + call pargstr (Memc[tmp]) + output = imtopen (Memc[outname]) + while (imtgetim (output, Memc[outname], SZ_FNAME) != EOF) + iferr (call imdelete (Memc[outname])) + ; + call imtclose (output) + masks = NULL + + call error (err, Memc[inname]) + } + + # Set the list to combine. If the input did not need to be + # transformed return the input pointer as the output pointer. + # The calling program can check for equality to decided whether + # to delete the temporary image. + + if (dotransform) { + call sprintf (Memc[outname], SZ_FNAME, "%s*") + call pargstr (Memc[tmp]) + output = imtopen (Memc[outname]) + call sprintf (Memc[outname], SZ_FNAME, "m%s*.pl") + call pargstr (Memc[tmp]) + masks = imtopen (Memc[outname]) + } else + output = input + + call sfree (sp) +end diff --git a/noao/twodspec/longslit/lstools.x b/noao/twodspec/longslit/lstools.x new file mode 100644 index 00000000..af16a971 --- /dev/null +++ b/noao/twodspec/longslit/lstools.x @@ -0,0 +1,131 @@ +include <imhdr.h> + +# LS_AIMSUM -- Get a one dimensional image vector summed over lines +# or columns. + +procedure ls_aimsum (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 + 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 + + +# LS_AIMAVG -- Get a one dimensional image vector averaged over lines +# or columns. + +procedure ls_aimavg (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 ls_aimsum (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 + + +# LS_IMMAP -- Map images for response and illumination calibrations + +procedure ls_immap (input, output, in, out) + +char input[ARB] # Input image +char output[ARB] # Output image +pointer in # Input IMIO pointer +pointer out # Output IMIO pointer + +pointer sp, root, sect, line, data + +int impnlr() +pointer immap() + +begin + # Get the root name and section of the input image. + + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (sect, SZ_FNAME, TY_CHAR) + + call get_root (input, Memc[root], SZ_FNAME) + call get_section (input, Memc[sect], SZ_FNAME) + + # If the output image is not accessible then create it as a new copy + # of the full input image and initialize the output to unit response. + + iferr (out = immap (output, READ_WRITE, 0)) { + in = immap (Memc[root], READ_ONLY, 0) + out = immap (output, NEW_COPY, in) + IM_PIXTYPE(out) = TY_REAL + + call salloc (line, IM_MAXDIM, TY_LONG) + call amovkl (long (1), Meml[line], IM_MAXDIM) + + while (impnlr (out, data, Meml[line]) != EOF) + call amovkr (1., Memr[data], IM_LEN(out, 1)) + + call imunmap (in) + } + call imunmap (out) + + # Map the input and output images. + + in = immap (input, READ_ONLY, 0) + + call sprintf (Memc[root], SZ_FNAME, "%s%s") + call pargstr (output) + call pargstr (Memc[sect]) + out = immap (Memc[root], READ_WRITE, 0) + + call sfree (sp) +end diff --git a/noao/twodspec/longslit/mkpkg b/noao/twodspec/longslit/mkpkg new file mode 100644 index 00000000..7af807cd --- /dev/null +++ b/noao/twodspec/longslit/mkpkg @@ -0,0 +1,41 @@ +# LONGSLIT Package + +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $update libpkg.a + $call longslit + ; + +install: + $move xx_longslit.e noaobin$x_longslit.e + ; + +longslit: + $omake x_longslit.x + $omake x_longslit.x + $link x_longslit.o libpkg.a -lsmw -lxtools -lcurfit -liminterp\ + -lgsurfit -o xx_longslit.e + ; + +libpkg.a: + @transform + @lscombine + + airmass.x <math.h> + extinction.x <error.h> <imhdr.h> + fluxcalib.x <error.h> <imhdr.h> <math/iminterp.h> + getdaxis.x + illumination.x <error.h> <imhdr.h> <math/iminterp.h> <pkg/gtools.h>\ + <pkg/rg.h> <pkg/xtanswer.h> + ilsetbins.x <gset.h> <imhdr.h> <pkg/gtools.h> <pkg/rg.h>\ + <pkg/xtanswer.h> + lstools.x <imhdr.h> + response.x <imhdr.h> <pkg/gtools.h> <pkg/xtanswer.h> + ; diff --git a/noao/twodspec/longslit/reidentify.par b/noao/twodspec/longslit/reidentify.par new file mode 100644 index 00000000..63412b0f --- /dev/null +++ b/noao/twodspec/longslit/reidentify.par @@ -0,0 +1,36 @@ +# Parameters for reidentify task. + +reference,s,a,,,,Reference image +images,s,a,,,,Images to be reidentified +interactive,s,h,"no","no|yes|NO|YES",,Interactive fitting? +section,s,h,"middle line",,,Section to apply to two dimensional images +newaps,b,h,yes,,,Reidentify apertures in images not in reference? +override,b,h,no,,,Override previous solutions? +refit,b,h,yes,,,"Refit coordinate function? +" +trace,b,h,yes,,,Trace reference image? +step,s,h,"10",,,Step in lines/columns/bands for tracing an image +nsum,s,h,"10",,,Number of lines/columns/bands to sum +shift,s,h,"0.",,,Shift to add to reference features (INDEF to search) +search,r,h,0.,,,Search radius +nlost,i,h,0,0,,"Maximum number of features which may be lost +" +cradius,r,h,5.,,,Centering radius +threshold,r,h,0.,0.,,Feature threshold for centering +addfeatures,b,h,no,,,Add features from a line list? +coordlist,f,h,linelists$idhenear.dat,,,User coordinate list +match,r,h,-3.,,,Coordinate list matching limit +maxfeatures,i,h,50,,,Maximum number of features for automatic identification +minsep,r,h,2.,0.,,"Minimum pixel separation +" +database,f,h,database,,,Database +logfiles,s,h,"logfile",,,List of log files +plotfile,s,h,"",,,Plot file for residuals +verbose,b,h,no,,,Verbose output? +graphics,s,h,"stdgraph",,,Graphics output device +cursor,*gcur,h,"",,,"Graphics cursor input +" +answer,s,q,"yes","no|yes|NO|YES",,Fit dispersion function interactively? +crval,s,q,,,,"Approximate coordinate (at reference pixel)" +cdelt,s,q,,,,"Approximate dispersion" +aidpars,pset,h,,,,"Automatic identification algorithm parameters" diff --git a/noao/twodspec/longslit/response.par b/noao/twodspec/longslit/response.par new file mode 100644 index 00000000..c7f1df84 --- /dev/null +++ b/noao/twodspec/longslit/response.par @@ -0,0 +1,18 @@ +# RESPONSE -- Determine response calibrations + +calibration,s,a,,,,Longslit calibration images +normalization,s,a,,,,Normalization spectrum images +response,s,a,,,,Response function images +interactive,b,h,yes,,,Fit normalization spectrum interactively? +threshold,r,h,INDEF,,,Response threshold + +sample,s,h,"*",,,Sample of points to use in fit +naverage,i,h,1,,,Number of points in sample averaging +function,s,h,"spline3","spline3|legendre|chebyshev|spline1",,Fitting function +order,i,h,1,1,,Order of fitting function +low_reject,r,h,0.,0.,,Low rejection in sigma of fit +high_reject,r,h,0.,0.,,High rejection in sigma of fit +niterate,i,h,1,0,,Number of rejection iterations +grow,r,h,0.,0.,,Rejection growing radius +graphics,s,h,"stdgraph",,,Graphics output device +cursor,*gcur,h,"",,,Graphics cursor input diff --git a/noao/twodspec/longslit/response.x b/noao/twodspec/longslit/response.x new file mode 100644 index 00000000..dd61ecc4 --- /dev/null +++ b/noao/twodspec/longslit/response.x @@ -0,0 +1,315 @@ +include <imhdr.h> +include <pkg/gtools.h> +include <pkg/xtanswer.h> + +# T_RESPONSE -- Determine the response function for 2D spectra. +# +# A calibration image is divided by a normalization spectrum to form +# a response image. The normalization spectrum is derived by averaging +# the normalization image across dispersion. The normalization spectrum +# is then smoothed by curve fitting. The smoothed normalization +# spectrum is divided into the calibration image to form the response +# function image. The curve fitting may be performed interactively +# using the icfit package. A response function is determined for each +# input image. Image sections in the calibration image may be used to determine +# the response for only part of an image such as with multiple slits. + +# CL callable task. +# +# The images are given by image templates. The number of images must +# in each list must match. Image sections are allowed in the calibration +# image. + +procedure t_response () + +int list1 # List of calibration images +int list2 # List of normalization images +int list3 # List of response images +real threshold # Response threshold +int naverage # Sample averaging size +int order # Order of curve fitting function +real low_reject, high_reject # Rejection thresholds +int niterate # Number of rejection iterations +real grow # Rejection growing radius +int interactive # Interactive? + +pointer cal, norm, resp, ic, gt +pointer sp, image1, image2, image3, history + +int clgeti(), imtopen(), imtgetim(), imtlen(), gt_init(), ic_geti() +bool clgetb() +real clgetr(), ic_getr() +pointer immap() + +errchk immap, ls_immap + +begin + call smark (sp) + call salloc (image1, SZ_LINE, TY_CHAR) + call salloc (image2, SZ_LINE, TY_CHAR) + call salloc (image3, SZ_LINE, TY_CHAR) + call salloc (history, SZ_LINE, TY_CHAR) + + # Get the calibration, normalization, and response image lists and + # check that the they match. + + call clgstr ("calibration", Memc[image1], SZ_LINE) + call clgstr ("normalization", Memc[image2], SZ_LINE) + call clgstr ("response", Memc[image3], SZ_LINE) + + list1 = imtopen (Memc[image1]) + list2 = imtopen (Memc[image2]) + list3 = imtopen (Memc[image3]) + if ((imtlen(list1)!=imtlen(list3)) || (imtlen(list2)!=imtlen(list3))) { + call imtclose (list1) + call imtclose (list2) + call imtclose (list3) + call error (0, "Image lists do not match") + } + + # Get remaining parameters and initialize the curve fitting package. + + threshold = clgetr ("threshold") + call clgstr ("sample", Memc[image1], SZ_LINE) + naverage = clgeti ("naverage") + call clgstr ("function", Memc[image2], SZ_LINE) + order = clgeti ("order") + low_reject = clgetr ("low_reject") + high_reject = clgetr ("high_reject") + niterate = clgeti ("niterate") + grow = clgetr ("grow") + if (clgetb ("interactive")) + interactive = YES + else + interactive = ALWAYSNO + + # Set the ICFIT pointer structure. + call ic_open (ic) + call ic_pstr (ic, "sample", Memc[image1]) + call ic_puti (ic, "naverage", naverage) + call ic_pstr (ic, "function", Memc[image2]) + call ic_puti (ic, "order", order) + call ic_putr (ic, "low", low_reject) + call ic_putr (ic, "high", high_reject) + call ic_puti (ic, "niterate", niterate) + call ic_putr (ic, "grow", grow) + call ic_pstr (ic, "ylabel", "") + + gt = gt_init() + call gt_sets (gt, GTTYPE, "line") + + # Create the response image for each calibration image. + + while ((imtgetim (list1, Memc[image1], SZ_LINE) != EOF) && + (imtgetim (list2, Memc[image2], SZ_LINE) != EOF) && + (imtgetim (list3, Memc[image3], SZ_LINE) != EOF)) { + + # Map the images. If the response image does not exist it + # is created and initialized to unit response everywhere. + # If the calibration image is an image section then the response + # image is opened as a section also. + + call ls_immap (Memc[image1], Memc[image3], cal, resp) + norm = immap (Memc[image2], READ_ONLY, 0) + + # Determine whether the normalization spectrum is to be fit + # interactively and if so set the graphics title. + + call sprintf (Memc[image2], SZ_LINE, + "Fit the normalization spectrum for %s interactively") + call pargstr (Memc[image1]) + call xt_answer (Memc[image2], interactive) + + if ((interactive == YES) || (interactive == ALWAYSYES)) { + call sprintf (Memc[image2], SZ_LINE, + "Fit the normalization spectrum for %s\n%s") + call pargstr (Memc[image1]) + call pargstr (IM_TITLE(cal)) + call gt_sets (gt, GTTITLE, Memc[image2]) + } + + # Make the response. + call re_make (cal, norm, resp, ic, gt, threshold, interactive) + + # Document the fit. + call ic_gstr (ic, "sample", Memc[history], SZ_LINE) + call clpstr ("sample", Memc[history]) + naverage = ic_geti (ic, "naverage") + call clputi ("naverage", naverage) + call ic_gstr (ic, "function", Memc[history], SZ_LINE) + call clpstr ("function", Memc[history]) + order = ic_geti (ic, "order") + call clputi ("order", order) + low_reject = ic_getr (ic, "low") + call clputr ("low_reject", low_reject) + high_reject = ic_getr (ic, "high") + call clputr ("high_reject", high_reject) + niterate = ic_geti (ic, "niterate") + call clputi ("niterate", niterate) + grow = ic_getr (ic, "grow") + call clputr ("grow", grow) + + call imaddr (resp, "ccdmean", 1.) + call sprintf (Memc[history], SZ_LINE, + "Response determined from %s.") + call pargstr (Memc[image2]) + call xt_phistory (resp, Memc[history]) + call imunmap (cal) + call imunmap (norm) + call imunmap (resp) + } + + # Finish up. + + call ic_closer (ic) + call imtclose (list1) + call imtclose (list2) + call imtclose (list3) + call gt_free (gt) + call sfree (sp) +end + + +# RE_MAKE -- Given the calibration image determine the response. + +procedure re_make (cal, norm, resp, ic, gt, threshold, interactive) + +pointer cal # Calibration IMIO pointer +pointer norm # Normalization IMIO pointer +pointer resp # Response IMIO pointer +pointer ic # ICFIT pointer +pointer gt # GTOOLS pointer +real threshold # Response threshold +int interactive # Interactive? + +char graphics[SZ_FNAME] # Graphics output device +int laxis, paxis, npts +pointer cv, gp, sp, wavelengths, spectrum, wts + +pointer gopen() +errchk get_daxis + +begin + # Determine the dispersion axis and set the axis labels. + call get_daxis (cal, laxis, paxis) + + switch (laxis) { + case 1: + call ic_pstr (ic, "xlabel", "Column") + case 2: + call ic_pstr (ic, "xlabel", "Line") + } + + # Get the normalization spectrum. + + call ls_aimavg (norm, laxis, 1, IM_LEN(norm, 1), 1, IM_LEN(norm, 2), + wavelengths, spectrum, npts) + + # Allocate memory for the fit. + + call smark (sp) + call salloc (wts, npts, TY_REAL) + call amovkr (1., Memr[wts], npts) + + # Smooth the normalization spectrum. + + call ic_putr (ic, "xmin", Memr[wavelengths]) + call ic_putr (ic, "xmax", Memr[wavelengths+npts-1]) + + if ((interactive == YES) || (interactive == ALWAYSYES)) { + call clgstr ("graphics", graphics, SZ_FNAME) + gp = gopen (graphics, NEW_FILE, STDGRAPH) + call icg_fit (ic, gp, "cursor", gt, cv, Memr[wavelengths], + Memr[spectrum], Memr[wts], npts) + call gclose (gp) + } else { + call ic_fit (ic, cv, Memr[wavelengths], Memr[spectrum], Memr[wts], + npts, YES, YES, YES, YES) + } + + call cvvector (cv, Memr[wavelengths], Memr[spectrum], npts) + call cvfree (cv) + + # Compute the response image by normalizing the calibration + # image by the normalization spectrum. + + call re_normalize (cal, resp, laxis, threshold, Memr[spectrum], npts) + + # Free allocated memory. + + call sfree (sp) + call mfree (wavelengths, TY_REAL) + call mfree (spectrum, TY_REAL) +end + + +# RE_NORMALIZE -- Divide each calibration image pixel by the normalization +# spectrum at that pixel. + +procedure re_normalize (cal, resp, axis, threshold, spectrum, npts) + +pointer cal # Calibration IMIO pointer +pointer resp # Response IMIO pointer +int axis # Dispersion axis +real threshold # Normalization treshold +real spectrum[npts] # Pointer to normalization spectrum +int npts # Number of points in spectrum + +int i, j, ncols, nlines +real norm +pointer datain, dataout + +pointer imgl2r(), impl2r() + +begin + ncols = IM_LEN (cal, 1) + nlines = IM_LEN (cal, 2) + + # Compute the response image. + if (IS_INDEF (threshold)) { + do i = 1, nlines { + datain = imgl2r (cal, i) + dataout = impl2r (resp, i) + + switch (axis) { + case 1: + call adivr (Memr[datain], spectrum, Memr[dataout], ncols) + case 2: + call adivkr (Memr[datain], spectrum[i], Memr[dataout], + ncols) + } + } + } else { + do i = 1, nlines { + datain = imgl2r (cal, i) + dataout = impl2r (resp, i) + + switch (axis) { + case 1: + do j = 1, ncols { + norm = spectrum[j] + if (norm < threshold || Memr[datain] < threshold) + Memr[dataout] = 1. + else + Memr[dataout] = Memr[datain] / norm + datain = datain + 1 + dataout = dataout + 1 + } + case 2: + norm = spectrum[i] + if (norm < threshold) + call amovkr (1., Memr[dataout], ncols) + else { + do j = 1, ncols { + if (Memr[datain] < threshold) + Memr[dataout] = 1. + else + Memr[dataout] = Memr[datain] / norm + datain = datain + 1 + dataout = dataout + 1 + } + } + } + } + } +end diff --git a/noao/twodspec/longslit/sensfunc.par b/noao/twodspec/longslit/sensfunc.par new file mode 100644 index 00000000..94f84f4a --- /dev/null +++ b/noao/twodspec/longslit/sensfunc.par @@ -0,0 +1,17 @@ +standards,s,a,std,,,Input standard star data file (from STANDARD) +sensitivity,s,a,"sens",,,Output root sensitivity function imagename +apertures,s,h,"",,,Aperture selection list +ignoreaps,b,h,yes,,,Ignore apertures and make one sensitivity function? +logfile,f,h,"logfile",,,Output log for statistics information +extinction,f,h,)_.extinction,,,Extinction file +newextinction,f,h,"extinct.dat",,,Output revised extinction file +observatory,s,h,)_.observatory,,,Observatory of data +function,s,h,"spline3","chebyshev|legendre|spline3|spline1",,Fitting function +order,i,h,6,1,,Order of fit +interactive,b,h,yes,,,Determine sensitivity function interactively? +graphs,s,h,"sr",,,Graphs per frame +marks,s,h,"plus cross box",,,Data mark types (marks deleted added) +colors,s,h,"2 1 3 4",,,Colors (lines marks deleted added) +cursor,*gcur,h,"",,,Graphics cursor input +device,s,h,"stdgraph",,,Graphics output device +answer,s,q, yes,"no|yes|NO|YES",,"(no|yes|NO|YES)" diff --git a/noao/twodspec/longslit/standard.par b/noao/twodspec/longslit/standard.par new file mode 100644 index 00000000..99b98877 --- /dev/null +++ b/noao/twodspec/longslit/standard.par @@ -0,0 +1,21 @@ +input,f,a,,,,Input image file root name +output,s,a,std,,,Output flux file (used by SENSFUNC) +samestar,b,h,yes,,,Same star in all apertures? +beam_switch,b,h,no,,,Beam switch spectra? +apertures,s,h,"",,,Aperture selection list +bandwidth,r,h,INDEF,,,Bandpass widths +bandsep,r,h,INDEF,,,Bandpass separation +fnuzero,r,h,3.68e-20,,,Absolute flux zero point +extinction,s,h,)_.extinction,,,Extinction file +caldir,s,h,)_.caldir,,,Directory containing calibration data +observatory,s,h,)_.observatory,,,Observatory for data +interact,b,h,yes,,,Graphic interaction to define new bandpasses +graphics,s,h,"stdgraph",,,Graphics output device +cursor,*gcur,h,"",,,Graphics cursor input +star_name,s,q,,,,Star name in calibration list +airmass,r,q,,1.,,Airmass +exptime,r,q,,,,Exposure time (seconds) +mag,r,q,,,,Magnitude of star +magband,s,q,,"U|B|V|R|I|J|H|K|L|Lprime|M",,"Magnitude type" +teff,s,q,,,,Effective temperature or spectral type +answer,s,q,no,,,"(no|yes|NO|YES|NO!|YES!)" diff --git a/noao/twodspec/longslit/transform.par b/noao/twodspec/longslit/transform.par new file mode 100644 index 00000000..c49485da --- /dev/null +++ b/noao/twodspec/longslit/transform.par @@ -0,0 +1,20 @@ +input,s,a,,,,Input images +output,s,a,,,,Output images +minput,s,h,"",,,Input masks +moutput,s,h,"",,,Output masks +fitnames,s,a,,,,Names of coordinate fits in the database +database,f,h,database,,,Identify database +interptype,s,h,spline3,"nearest|linear|poly3|poly5|spline3",,Interpolation type +x1,r,h,INDEF,,,Output starting x coordinate +x2,r,h,INDEF,,,Output ending x coordinate +dx,r,h,INDEF,,,Output X pixel interval +nx,r,h,INDEF,,,Number of output x pixels +xlog,b,h,no,,,Logarithmic x coordinate? +y1,r,h,INDEF,,,Output starting y coordinate +y2,r,h,INDEF,,,Output ending y coordinate +dy,r,h,INDEF,,,Output Y pixel interval +ny,r,h,INDEF,,,Number of output y pixels +ylog,b,h,no,,,Logarithmic y coordinate? +flux,b,h,yes,,,Conserve flux per pixel? +blank,r,h,INDEF,,,Value for out of range pixels +logfiles,s,h,"STDOUT,logfile",,,List of log files diff --git a/noao/twodspec/longslit/transform/Notes b/noao/twodspec/longslit/transform/Notes new file mode 100644 index 00000000..16f5a7a3 --- /dev/null +++ b/noao/twodspec/longslit/transform/Notes @@ -0,0 +1,6 @@ +May 29, 1987 + +If a user accidentally leaves the user coordinate as INDEF in tracing +the spatial distortion then FITCOORDS uses the fitted coordinate +which is the same as the pixel coordinate. This causes incorrect +results. Some thought should be given to this situation. diff --git a/noao/twodspec/longslit/transform/fcdbio.x b/noao/twodspec/longslit/transform/fcdbio.x new file mode 100644 index 00000000..caf4ac5d --- /dev/null +++ b/noao/twodspec/longslit/transform/fcdbio.x @@ -0,0 +1,99 @@ +include <error.h> +include <math/gsurfit.h> +include <pkg/dttext.h> +include <units.h> + +# FC_DBWRITE -- Write an fitcoords database entry. + +procedure fc_dbwrite (database, fitname, axis, un, sf) + +char database[ARB] # Database +char fitname[ARB] # Database fit name +int axis # Axis for surface +pointer un # Units pointer +pointer sf # Surface pointer + +int i, nsave +pointer dt, coeffs, sp, dbfile + +int xgsgeti() +pointer dtmap1() + +begin + if (sf == NULL) + return + + call smark (sp) + call salloc (dbfile, SZ_FNAME, TY_CHAR) + call strcpy ("fc", Memc[dbfile], SZ_FNAME) + call imgcluster (fitname, Memc[dbfile+2], SZ_FNAME-2) + dt = dtmap1 (database, Memc[dbfile], APPEND) + + call dtptime (dt) + call dtput (dt, "begin\t%s\n") + call pargstr (fitname) + call dtput (dt, "\ttask\tfitcoords\n") + call dtput (dt, "\taxis\t%d\n") + call pargi (axis) + if (un != NULL) { + call dtput (dt, "\tunits\t%s\n") + call pargstr (UN_UNITS(un)) + } + + nsave = xgsgeti (sf, GSNSAVE) + call salloc (coeffs, nsave, TY_DOUBLE) + call xgssave (sf, Memd[coeffs]) + call dtput (dt, "\tsurface\t%d\n") + call pargi (nsave) + do i = 1, nsave { + call dtput (dt, "\t\t%g\n") + call pargd (Memd[coeffs+i-1]) + } + + call sfree (sp) + call dtunmap (dt) +end + + +# LM_DBREAD -- Read an lsmap database entry. + +procedure lm_dbread (database, fitname, axis, un, sf) + +char database[ARB] # Database +char fitname[ARB] # Fit name +int axis # Axis for surface +pointer un # Units pointer +pointer sf # Surface pointer + +int rec, ncoeffs +pointer dt, coeffs, sp, dbfile, units + +int dtlocate(), dtgeti() +pointer dtmap1(), un_open() + +errchk dtlocate(), dtgeti(), dtgad(), un_open() + +begin + un = NULL + sf = NULL + coeffs = NULL + + call smark (sp) + call salloc (dbfile, SZ_FNAME, TY_CHAR) + call salloc (units, SZ_FNAME, TY_CHAR) + call strcpy ("fc", Memc[dbfile], SZ_FNAME) + call imgcluster (fitname, Memc[dbfile+2], SZ_FNAME-2) + dt = dtmap1 (database, Memc[dbfile], READ_ONLY) + + rec = dtlocate (dt, fitname) + axis = dtgeti (dt, rec, "axis") + ifnoerr (call dtgstr (dt, rec, "units", Memc[units], SZ_FNAME)) + un = un_open (Memc[units]) + ncoeffs = dtgeti (dt, rec, "surface") + call salloc (coeffs, ncoeffs, TY_DOUBLE) + call dtgad (dt, rec, "surface", Memd[coeffs], ncoeffs, ncoeffs) + call xgsrestore (sf, Memd[coeffs]) + + call sfree (sp) + call dtunmap (dt) +end diff --git a/noao/twodspec/longslit/transform/fcdlist.x b/noao/twodspec/longslit/transform/fcdlist.x new file mode 100644 index 00000000..7b9816a7 --- /dev/null +++ b/noao/twodspec/longslit/transform/fcdlist.x @@ -0,0 +1,91 @@ +include <mach.h> +include <error.h> + +# FC_DLIST -- Fit Coordinates Deletion List Procedures. + +# FC_DLREAD -- Fit Coordinates Deletion List Read. +# Read the deletion list file and match points in the list with the data +# and delete them. + +procedure fc_dlread (x, y, w, npts) + +real x[npts] # First coordinate to match +real y[npts] # Second coordinate to match +real w[npts] # Weight of coordinate +int npts # Number of coordinates + +int i, fd +real r +char file[SZ_FNAME] +real xdel, ydel + +int access(), open(), fscan(), nscan() + +begin + call clgstr ("deletions", file, SZ_FNAME) + + if (access (file, READ_ONLY, TEXT_FILE) == NO) + return + + fd = open (file, READ_ONLY, TEXT_FILE) + + while (fscan (fd) != EOF) { + call gargr (xdel) + call gargr (ydel) + + if (nscan() != 2) + next + + do i = 1, npts { + r = sqrt ((x[i]-xdel)**2 + (y[i]-ydel)**2) + if (r < 10*EPSILONR) + w[i] = 0. +# if (x[i] != xdel) +# next +# if (y[i] != ydel) +# next +# w[i] = 0. + } + } + + call close (fd) +end + + +# FC_DLWRITE -- Fit Coordinates Deletion List Write. + +procedure fc_dlwrite (x, y, w, npts) + +real x[npts] # First coordinate to match +real y[npts] # Second coordinate to match +real w[npts] # Weight of coordinate +int npts # Number of coordinates + +int i, fd +char file[SZ_FNAME] + +int open() + +begin + call clgstr ("deletions", file, SZ_FNAME) + + if (file[1] == EOS) + return + + iferr (call delete (file)) + ; + iferr (fd = open (file, NEW_FILE, TEXT_FILE)) { + call erract (EA_WARN) + return + } + + do i = 1, npts { + if (w[i] == 0.) { + call fprintf (fd, "%g %g\n") + call pargr (x[i]) + call pargr (y[i]) + } + } + + call close (fd) +end diff --git a/noao/twodspec/longslit/transform/fcfitcoords.x b/noao/twodspec/longslit/transform/fcfitcoords.x new file mode 100644 index 00000000..13943302 --- /dev/null +++ b/noao/twodspec/longslit/transform/fcfitcoords.x @@ -0,0 +1,211 @@ +include <pkg/gtools.h> +include <pkg/igsfit.h> +include <pkg/xtanswer.h> + +# FC_FITCOORDS -- Fit a surface to the user coordinates. + +procedure fc_fitcoords (fitname, database, list, logfiles, interactive) + +char fitname[SZ_FNAME] # Fitname +char database[SZ_FNAME] # Database +int list # List of images +int logfiles # List of log files +int interactive # Interactive? + +int axis # Axis of surface fit +pointer sf # Surface pointer +char logfile[SZ_FNAME], labels[SZ_LINE, IGSPARAMS] +bool answer +int ncoords, logfd, axes[2] +real xmin, xmax, ymin, ymax +pointer gp, gplog, gt, coords, title, un + +int imtgetim(), fntgfntb(), open(), igs_geti(), scan() +real xgseval() +pointer gopen(), gt_init() + +errchk fc_getcoords + +begin + # Print a header to the log files giving the inputs. This is + # done first so that if one of the logfiles is STDOUT the user + # will see that something is happening. + + axis = 0 + while (fntgfntb (logfiles, logfile, SZ_FNAME) != EOF) { + logfd = open (logfile, APPEND, TEXT_FILE) + call sysid (logfile, SZ_FNAME) + call fprintf (logfd, "\n%s\n") + call pargstr (logfile) + call fprintf (logfd, " Longslit coordinate fit name is %s.\n") + call pargstr (fitname) + call fprintf (logfd, " Longslit database is %s.\n") + call pargstr (database) + call fprintf (logfd, " Features from images:\n") + while (imtgetim (list, logfile, SZ_FNAME) != EOF) { + call fprintf (logfd, " %s\n") + call pargstr (logfile) + } + call imtrew (list) + call close (logfd) + } + call fntrewb (logfiles) + + # Get the coordinates for the specified images and axis. The + # coordinates are returned in a pointer which must be explicitly + # freed. + + call fc_getcoords (database, list, axis, xmin, xmax, ymin, ymax, + coords, ncoords, labels, un) + + # Read points from the deletion list. + + switch (axis) { + case 1: + call fc_dlread (Memr[coords+(Z-1)*ncoords], + Memr[coords+(Y-1)*ncoords], Memr[coords+(W-1)*ncoords], ncoords) + case 2: + call fc_dlread (Memr[coords+(Z-1)*ncoords], + Memr[coords+(X-1)*ncoords], Memr[coords+(W-1)*ncoords], ncoords) + } + + # Initialize the graphics. + + if ((interactive == YES) || (interactive == ALWAYSYES)) { + call clgstr ("graphics", logfile, SZ_FNAME) + gp = gopen (logfile, NEW_FILE, STDGRAPH) + } + + # Set plot log. + + gplog = NULL + call clgstr ("plotfile", logfile, SZ_FNAME) + if (logfile[1] != EOS) { + logfd = open (logfile, APPEND, BINARY_FILE) + gplog = gopen ("stdplot", APPEND, logfd) + } else + gplog = NULL + + gt = gt_init () + call malloc (title, SZ_LINE, TY_CHAR) + call sprintf (Memc[title], SZ_LINE, + "Fit User Coordinates to Image Coordinates for %s") + call pargstr (fitname) + call gt_sets (gt, GTTITLE, Memc[title]) + call mfree (title, TY_CHAR) + + # Fit the surface. The surface is defined over the full range of + # image coordinates. + + call igs_setr (IGS_XMIN, xmin) + call igs_setr (IGS_XMAX, xmax) + call igs_setr (IGS_YMIN, ymin) + call igs_setr (IGS_YMAX, ymax) + + switch (axis) { + case 1: + if (Memr[coords+ncoords-1] == 1) { + axes[1] = Y + axes[2] = R + call igs_fit2 (sf, gp, gplog, gt, axes, Memr[coords], ncoords, + labels, interactive) + } else { + axes[1] = X + axes[2] = R + call igs_fit1 (sf, gp, gplog, gt, axes, Memr[coords], ncoords, + labels, interactive) + } + case 2: + if (Memr[coords+ncoords-1] == 1) { + axes[1] = X + axes[2] = R + call igs_fit3 (sf, gp, gplog, gt, axes, Memr[coords], ncoords, + labels, interactive) + } else { + axes[1] = Y + axes[2] = R + call igs_fit1 (sf, gp, gplog, gt, axes, Memr[coords], ncoords, + labels, interactive) + } + } + + # Close graphics. + + if (gp != NULL) + call gclose (gp) + if (gplog != NULL) { + call gclose (gplog) + call close (logfd) + } + call gt_free (gt) + + # Print logs. + + while (fntgfntb (logfiles, logfile, SZ_FNAME) != EOF) { + logfd = open (logfile, APPEND, TEXT_FILE) + call fprintf (logfd, + " Map %s coordinates for axis %d using image features:\n") + call pargstr (labels[1, Z]) + call pargi (axis) + call fprintf (logfd, " Number of feature coordnates = %d\n") + call pargi (ncoords) + call igs_gets (IGS_FUNCTION, logfile, SZ_FNAME) + call fprintf (logfd, " Mapping function = %s\n") + call pargstr (logfile) + call fprintf (logfd, " X order = %d\n Y order = %d\n") + call pargi (igs_geti (IGS_XORDER)) + call pargi (igs_geti (IGS_YORDER)) + call fprintf (logfd, + " Fitted coordinates at the corners of the images:\n") + call fprintf (logfd, " (%d, %d) = %g (%d, %d) = %g\n") + call pargr (xmin) + call pargr (ymin) + call pargr (xgseval (sf, xmin, ymin)) + call pargr (xmax) + call pargr (ymin) + call pargr (xgseval (sf, xmax, xmin)) + call fprintf (logfd, " (%d, %d) = %g (%d, %d) = %g\n") + call pargr (xmin) + call pargr (ymax) + call pargr (xgseval (sf, xmin, ymax)) + call pargr (xmax) + call pargr (ymax) + call pargr (xgseval (sf, xmax, ymax)) + call close (logfd) + } + call fntrewb (logfiles) + + # Write the fit to the database. + + answer = true + if ((interactive == YES) || (interactive == ALWAYSYES)) { + call printf ("Write coordinate map to the database (yes)? ") + call flush (STDOUT) + if (scan() != EOF) + call gargb (answer) + } + if (answer) + call fc_dbwrite (database, fitname, axis, un, sf) + + # Write list of deleted points. + + if ((interactive == YES) || (interactive == ALWAYSYES)) { + switch (axis) { + case 1: + call fc_dlwrite (Memr[coords+(Z-1)*ncoords], + Memr[coords+(Y-1)*ncoords], + Memr[coords+(W-1)*ncoords], ncoords) + case 2: + call fc_dlwrite (Memr[coords+(Z-1)*ncoords], + Memr[coords+(X-1)*ncoords], + Memr[coords+(W-1)*ncoords], ncoords) + } + } + + # Free memory. + + call mfree (coords, TY_REAL) + if (un != NULL) + call un_close (un) + call xgsfree (sf) +end diff --git a/noao/twodspec/longslit/transform/fcgetcoords.x b/noao/twodspec/longslit/transform/fcgetcoords.x new file mode 100644 index 00000000..dda1c0f0 --- /dev/null +++ b/noao/twodspec/longslit/transform/fcgetcoords.x @@ -0,0 +1,212 @@ +include <imio.h> +include <mach.h> +include <mwset.h> +include <pkg/dttext.h> +include <pkg/igsfit.h> + +# FC_GETCOORDS -- Get feature coordinates for the specified axis and list +# of images. Determine the image dimensions. + +procedure fc_getcoords (database, list, axis, xmin, xmax, ymin, ymax, + coords, ncoords, labels, un) + +char database[ARB] # Database +int list # List of images +int axis # Image axis +real xmin, xmax # Image X limits +real ymin, ymax # Image Y limits +pointer coords # Coordinate data pointer +pointer ncoords # Number of coordinate points +char labels[SZ_LINE,IGSPARAMS] # Axis labels +pointer un # Units pointer + +char image1[SZ_FNAME], image2[SZ_FNAME], root[SZ_FNAME], units[SZ_FNAME] +int i, j, rec, index, imin, imax, nfeatures, ntotal +real value, wt, ltm[2,2], ltv[2] +pointer dt, im, mw, ct, x, y, user + +int fc_getim(), dtgeti(), dtscan(), mw_stati() +real mw_c1tranr() +bool strne() +pointer dtmap1(), immap(), mw_openim(), mw_sctran(), un_open() + +errchk dtmap1, dtgstr, immap + +begin + x = NULL + ncoords = 0 + ntotal = 0 + axis = 0 + imin = MAX_INT + imax = -MAX_INT + un = NULL + + while (fc_getim (list, image1, SZ_FNAME) != EOF) { + call strcpy ("id", root, SZ_FNAME) + call imgcluster (image1, root[3], SZ_FNAME-2) + dt = dtmap1 (database, root, READ_ONLY) + do rec = 1, DT_NRECS(dt) { + + iferr (call dtgstr (dt, rec, "task", image2, SZ_FNAME)) + next + if (strne ("identify", image2)) + next + + call dtgstr (dt, rec, "image", image2, SZ_FNAME) + call get_root (image2, root, SZ_FNAME) + if (strne (image1, root)) + next + + # Map the 1D image section and determine the axis, the + # line or column in the 2D image, and the 2D image size. + + im = immap (image2, READ_ONLY, 0) + j = IM_VMAP(im, 1) + switch (j) { + case 1: + index = IM_VOFF (im, 2) + 1 + case 2: + index = IM_VOFF (im, 1) + 1 + } + imin = min (imin, index) + imax = max (imax, index) + + xmin = 1. + xmax = IM_SVLEN (im, 1) + ymin = 1. + ymax = IM_SVLEN (im, 2) + + if (axis == 0) + axis = j + + if (j != axis) { + call imunmap (im) + call eprintf ( + "Warning: Fit axes don't agree for combine option. Ignoring %s.\n") + call pargstr (image1) + break + } + + # Set the WCS to convert the feature positions from + # IDENTIFY/REIDENTIFY which are in "physical" coordinates + # to "logical" coordinates currently used by TRANSFORM. + + mw = mw_openim (im) + call mw_seti (mw, MW_USEAXMAP, NO) + i = mw_stati (mw, MW_NPHYSDIM) + call mw_gltermr (mw, ltm, ltv, i) + if (ltm[1,1] == 0. && ltm[2,2] == 0.) { + ltm[1,1] = ltm[2,1] + ltm[2,1] = 0. + ltm[2,2] = ltm[1,2] + ltm[1,2] = 0. + call mw_sltermr (mw, ltm, ltv, i) + } else if (ltm[1,2] != 0. || ltm[2,1] != 0.) { + ltv[1] = 0. + ltv[2] = 0. + ltm[1,1] = 1. + ltm[2,1] = 0. + ltm[2,2] = 1. + ltm[1,2] = 0. + call mw_sltermr (mw, ltm, ltv, i) + } + call mw_seti (mw, MW_USEAXMAP, YES) + ct = mw_sctran (mw, "physical", "logical", 1) + + # Allocate memory for the feature information and read + # the database. + + ifnoerr (call dtgstr (dt, rec, "units", units, SZ_FNAME)) + un = un_open (units) + nfeatures = dtgeti (dt, rec, "features") + if (x == NULL) { + call malloc (x, nfeatures, TY_REAL) + call malloc (y, nfeatures, TY_REAL) + call malloc (user, nfeatures, TY_REAL) + } else { + call realloc (x, ncoords+nfeatures, TY_REAL) + call realloc (y, ncoords+nfeatures, TY_REAL) + call realloc (user, ncoords+nfeatures, TY_REAL) + } + + do i = 1, nfeatures { + j = dtscan (dt) + call gargr (value) + switch (axis) { + case 1: + Memr[x+ncoords] = mw_c1tranr (ct, value) + Memr[y+ncoords] = index + case 2: + Memr[x+ncoords] = index + Memr[y+ncoords] = mw_c1tranr (ct, value) + } + call gargr (value) + call gargr (value) + call gargr (wt) + call gargr (wt) + call gargr (wt) + if (!IS_INDEF (value) && wt > 0.) { + Memr[user+ncoords] = value + ncoords = ncoords + 1 + } + ntotal = ntotal + 1 + } + call mw_close (mw) + call imunmap (im) + } + + # Finish up + call dtunmap (dt) + } + + # Set coordinates. Take error action if no features are found. + + if (ncoords > 0) { + call xt_sort3 (Memr[user], Memr[x], Memr[y], ncoords) + call malloc (coords, ncoords*IGSPARAMS, TY_REAL) + call amovr (Memr[x], Memr[coords+(X-1)*ncoords], ncoords) + call amovr (Memr[y], Memr[coords+(Y-1)*ncoords], ncoords) + call amovr (Memr[user], Memr[coords+(Z-1)*ncoords], ncoords) + call amovkr (1., Memr[coords+(W-1)*ncoords], ncoords) + + call fc_setfeatures (Memr[coords], Memr[coords+(Z-1)*ncoords], + ncoords) + + call strcpy ("X (pixels)", labels[1,X], SZ_LINE) + call strcpy ("Y (pixels)", labels[1,Y], SZ_LINE) + call strcpy ("User", labels[1,Z], SZ_LINE) + call strcpy ("Surface", labels[1,S], SZ_LINE) + call strcpy ("Residuals", labels[1,R], SZ_LINE) + } + + call mfree (x, TY_REAL) + call mfree (y, TY_REAL) + call mfree (user, TY_REAL) + + if (ncoords == 0) { + if (ntotal == 0) + call error (1, "No coordinates found in database") + else + call error (1, "Only INDEF coordinates found in database") + } +end + + +# FC_SETFEATURES -- Set the feature numbers. + +procedure fc_setfeatures (features, user, npts) + +real features[npts] # Feature numbers +real user[npts] # User coordinates +int npts # Number of points + +int i + +begin + features[1] = 1 + do i = 2, npts { + features[i] = features[i-1] + if (user[i] != user[i-1]) + features[i] = features[i] + 1 + } +end diff --git a/noao/twodspec/longslit/transform/fcgetim.x b/noao/twodspec/longslit/transform/fcgetim.x new file mode 100644 index 00000000..e76ba25a --- /dev/null +++ b/noao/twodspec/longslit/transform/fcgetim.x @@ -0,0 +1,32 @@ +# FC_GETIM -- Get next image name with standard image extensions removed. +# This is necessary to avoid having two legal image names refering to the +# same image. + +int procedure fc_getim (list, image, maxchar) + +int list # Image list +char image[maxchar] # Image name +int maxchar # Maximum number of chars in image name + +int i, stat, imtgetim(), strmatch() + +begin + stat = imtgetim (list, image, maxchar) + + if (stat == EOF) + return (stat) + + i = strmatch (image, ".imh") + if (i > 0) { + call strcpy (image[i], image[i-4], maxchar) + return (stat) + } + + i = strmatch (image, ".hhh") + if (i > 0) { + call strcpy (image[i], image[i-4], maxchar) + return (stat) + } + + return (stat) +end diff --git a/noao/twodspec/longslit/transform/fitcoords.x b/noao/twodspec/longslit/transform/fitcoords.x new file mode 100644 index 00000000..e849caf2 --- /dev/null +++ b/noao/twodspec/longslit/transform/fitcoords.x @@ -0,0 +1,83 @@ +include <error.h> +include <pkg/igsfit.h> +include <pkg/xtanswer.h> + +# T_FITCOORDS -- Fit a surface to the coordinates of longslit images. +# +# This is the CL entry for this task. All the real work is done by +# fc_fitcoords. + +procedure t_fitcoords () + +int list1 # Image list +char fitname[SZ_FNAME] # Database name for coordinate fit +char database[SZ_FNAME] # Database +int logfiles # List of log files +bool combine # Combine input data? +int interactive # Interactive? + +char image[SZ_FNAME], prompt[SZ_LINE] +int list2 + +int clgeti(), clpopnu(), imtopen(), fc_getim() +bool clgetb() + +begin + # Get the task parameters. + + call clgstr ("fitname", fitname, SZ_FNAME) + call xt_stripwhite (fitname) + combine = clgetb ("combine") + + if (combine && (fitname[1] == EOS)) + call error (0, "Fit name not specified") + + call clgstr ("images", prompt, SZ_LINE) + list1 = imtopen (prompt) + call clgstr ("database", database, SZ_FNAME) + logfiles = clpopnu ("logfiles") + if (clgetb ("interactive")) + interactive = YES + else + interactive = ALWAYSNO + + # Set the initial surface in the igsfit package. + + call clgstr ("function", prompt, SZ_LINE) + call igs_sets (IGS_FUNCTION, prompt) + call igs_seti (IGS_XORDER, clgeti ("xorder")) + call igs_seti (IGS_YORDER, clgeti ("yorder")) + + # For each fit ask the user whether to do the fit interactively. + # If combining the coordinates from all the images in the + # input list then pass the list directly to fc_fitcoords. + # Otherwise for each image in the list create a second list + # containing just that image. A second list is needed because + # fc_fitcoords expects a list. + + if (combine) { + call sprintf (prompt, SZ_LINE, "Fit interactively") + call xt_answer (prompt, interactive) + call fc_fitcoords (fitname, database, list1, logfiles, interactive) + + } else { + while (fc_getim (list1, image, SZ_FNAME) != EOF) { + list2 = imtopen (image) + call sprintf (prompt, SZ_LINE, "Fit %s interactively") + call pargstr (image) + call xt_answer (prompt, interactive) + call sprintf (prompt, SZ_LINE, "%s%s") + call pargstr (fitname) + call pargstr (image) + iferr (call fc_fitcoords (prompt, database, list2, logfiles, + interactive)) + call erract (EA_WARN) + call imtclose (list2) + } + } + + # Finish up. + + call clpcls (logfiles) + call imtclose (list1) +end diff --git a/noao/twodspec/longslit/transform/igsfit/Revisions b/noao/twodspec/longslit/transform/igsfit/Revisions new file mode 100644 index 00000000..92b36cca --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/Revisions @@ -0,0 +1,42 @@ +.help revisions Jun88 noao.twodspec.longslit.transform.igsfit +.nf + igsfit.x + igsnearest.x + GSCUR was being called with DOUBLE precision values. (12/22/87) + + igsfit.x + igscolon.x + igsget.x + Added colon options to print fit at corners of surface. (8/10/87 Valdes) + + ==== + V2.5 + ==== + +noao$twodspec/longslit/transform/igsfit/*.x + Valdes, February 17, 1987 + 1. GIO changes. + +noao$twodspec/longslit/transform/igsfit/igsfit.x +noao$twodspec/longslit/transform/igsfit/igscolon.x + Valdes, January 16, 1987 + 1. '?' now uses system page facility. + 2. Colon command dictionary and switch modified to use macro definitions. + +noao$twodspec/longslit/transform/igsfit/igsdelete.x +noao$twodspec/longslit/transform/igsfit/igsundelete.x + Valdes, October 16, 1986 + 1. Real line type specified in gseti call changed to integer. + This caused a crash on AOS/IRAF. + +======================================================== + +From Valdes on Feb 7, 1986: + +1. Bug fixed in deleting and undeleting points. +------ +From Valdes on Jan 3, 1986: + +1. Modified IGSFIT to allow zooming on constant x, constant y, constant z, +and constant feature. +.endhelp diff --git a/noao/twodspec/longslit/transform/igsfit/igscolon.x b/noao/twodspec/longslit/transform/igsfit/igscolon.x new file mode 100644 index 00000000..6847974a --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igscolon.x @@ -0,0 +1,115 @@ +include <gset.h> + +# List of colon commands +define CMDS "|show|function|xorder|yorder|corners|" + +define SHOW 1 # Show parameters +define FUNCTION 2 # Set or show function type +define XORDER 3 # Set or show x order of function +define YORDER 4 # Set or show y order of function +define CORNERS 5 # Show corners + +# IGS_COLON -- Processes colon commands. + +procedure igs_colon (cmdstr, gp, sf) + +char cmdstr[ARB] # Command string +pointer gp # GIO pointer +pointer sf # Surface pointer + +char cmd[SZ_LINE] +int ncmd, ival + +int nscan(), strdic() +real xgseval() + +string funcs "|chebyshev|legendre|" + +include "igsfit.com" + +begin + # 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 (cmd, SZ_LINE) + ncmd = strdic (cmd, cmd, SZ_LINE, CMDS) + + switch (ncmd) { + case SHOW: # :show - Show the values of the fitting parameters. + call gdeactivate (gp, AW_CLEAR) + call printf ("function %s\n") + call pargstr (function) + call printf ("xorder %d\n") + call pargi (xorder) + call printf ("yorder %d\n") + call pargi (yorder) + call printf ("Fitted coordinates at the corners of the images:\n") + call printf (" (%d, %d) = %g (%d, %d) = %g\n") + call pargr (xmin) + call pargr (ymin) + call pargr (xgseval (sf, xmin, ymin)) + call pargr (xmax) + call pargr (ymin) + call pargr (xgseval (sf, xmax, xmin)) + call printf (" (%d, %d) = %g (%d, %d) = %g\n") + call pargr (xmin) + call pargr (ymax) + call pargr (xgseval (sf, xmin, ymax)) + call pargr (xmax) + call pargr (ymax) + call pargr (xgseval (sf, xmax, ymax)) + call printf ("rms %g\n") + call pargr (rms) + call greactivate (gp, AW_PAUSE) + + case FUNCTION: # :function - List or set the fitting function. + call gargwrd (cmd, SZ_LINE) + if (nscan() == 1) { + call printf ("function = %s\n") + call pargstr (function) + } else { + if (strdic (cmd, cmd, SZ_LINE, funcs) > 0) + call strcpy (cmd, function, SZ_LINE) + else + call printf ("Unknown or ambiguous function\n") + } + + case XORDER: # xorder: List or set the function order. + call gargi (ival) + if (nscan() == 1) { + call printf ("xorder %d\n") + call pargi (xorder) + } else if (ival < 2) + call printf ("xorder must be at least 2\n") + else + xorder = ival + + case YORDER: # yorder: List or set the function order. + call gargi (ival) + if (nscan() == 1) { + call printf ("yorder %d\n") + call pargi (yorder) + } else if (ival < 2) + call printf ("yorder must be at least 2\n") + else + yorder = ival + case CORNERS: # corners: List coordinates at corners. + call printf ("(%d,%d)=%g (%d,%d)=%g (%d,%d)=%g (%d,%d)=%g\n") + call pargr (xmin) + call pargr (ymin) + call pargr (xgseval (sf, xmin, ymin)) + call pargr (xmax) + call pargr (ymin) + call pargr (xgseval (sf, xmax, xmin)) + call pargr (xmin) + call pargr (ymax) + call pargr (xgseval (sf, xmin, ymax)) + call pargr (xmax) + call pargr (ymax) + call pargr (xgseval (sf, xmax, ymax)) + default: + call printf ("Unrecognized or ambiguous command\007") + } +end diff --git a/noao/twodspec/longslit/transform/igsfit/igsdelete.x b/noao/twodspec/longslit/transform/igsfit/igsdelete.x new file mode 100644 index 00000000..3de2fb25 --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igsdelete.x @@ -0,0 +1,103 @@ +include <mach.h> +include <gset.h> +include <pkg/gtools.h> +include <pkg/igsfit.h> + +# IGS_NEARESTD -- Nearest point to delete. + +int procedure igs_nearestd (gp, ztype, refpt, axis, pts, npts, wx, wy, wcs) + +pointer gp # GIO pointer +int ztype # Zoom type +int refpt # Reference point +int axis[2] # Axes +real pts[npts, ARB] # Data points +int npts # Number of data points +real wx, wy # Cursor coordinates +int wcs # WCS + +int i, j, x, y +real r2, r2min, x0, y0 + +begin + x = axis[1] + y = axis[2] + + call gctran (gp, wx, wy, wx, wy, wcs, 0) + r2min = MAX_REAL + j = 0 + + if (IS_INDEFI (ztype)) { + do i = 1, npts { + if (pts[i,W] == 0.) + next + call gctran (gp, pts[i, x], pts[i, y], x0, y0, wcs, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + } else { + do i = 1, npts { + if ((pts[i,ztype] != pts[refpt,ztype]) || (pts[i,W] == 0.)) + next + call gctran (gp, pts[i, x], pts[i, y], x0, y0, wcs, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + } + + return (j) +end + +# IGS_DELETE -- Delete points or subsets. + +procedure igs_delete (gp, gt, ztype, refpt, axis, pts, npts, dtype) + +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +int ztype # Zoom type +int refpt # Reference point for deletion +int axis[2] # Axes +real pts[npts, ARB] # Data points +int npts # Number of data points +int dtype # Deletion type + +int i, x, y +real xsize, ysize + +real gt_getr() + +begin + x = axis[1] + y = axis[2] + + xsize = gt_getr (gt, GTXSIZE) + ysize = gt_getr (gt, GTYSIZE) + + switch (dtype) { + case X, Y, Z: + do i = 1, npts { + if (!IS_INDEFI (ztype)) + if (pts[i,ztype] != pts[refpt,ztype]) + next + if (pts[i,dtype] != pts[refpt,dtype]) + next + call gseti (gp, G_PMLTYPE, 0) + call gmark (gp, pts[i,x], pts[i,y], GM_PLUS, xsize, ysize) + call gseti (gp, G_PMLTYPE, 1) + call gmark (gp, pts[i,x], pts[i,y], GM_CROSS, xsize, ysize) + pts[i,W] = 0. + } + default: + call gseti (gp, G_PMLTYPE, 0) + call gmark (gp, pts[refpt,x], pts[refpt,y], GM_PLUS, xsize, ysize) + call gseti (gp, G_PMLTYPE, 1) + call gmark (gp, pts[refpt,x], pts[refpt,y], GM_CROSS, xsize, ysize) + pts[refpt,W] = 0. + } +end diff --git a/noao/twodspec/longslit/transform/igsfit/igsfit.com b/noao/twodspec/longslit/transform/igsfit/igsfit.com new file mode 100644 index 00000000..90bf90aa --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igsfit.com @@ -0,0 +1,10 @@ +# Common parameters. + +char function[SZ_LINE] # Surface function +int xorder # X order of surface function +int yorder # Y order of surface function +real xmin, xmax # X range +real ymin, ymax # Y range +real mean, rms # Mean and RMS of fit + +common /igscom/ xmin, xmax, ymin, ymax, xorder, yorder, function, mean, rms diff --git a/noao/twodspec/longslit/transform/igsfit/igsfit.x b/noao/twodspec/longslit/transform/igsfit/igsfit.x new file mode 100644 index 00000000..14e8e51e --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igsfit.x @@ -0,0 +1,373 @@ +include <mach.h> +include <pkg/gtools.h> +include <pkg/igsfit.h> + +define HELP "noao$lib/scr/igsfit.key" +define PROMPT "fitcoords surface fitting options" + + +# IGS_FIT1 -- Fit z = f(x, y) + +procedure igs_fit1 (sf, gp, gplog, gt, axis, pts, npts, labels, interactive) + +pointer sf # GSURFIT pointer +pointer gp # GIO pointer +pointer gplog # GIO pointer for plot log +pointer gt # GTOOLS pointer +int axis[2] # Axis definitions +real pts[npts, ARB] # Data +int npts # Number of pts points +char labels[SZ_LINE, ARB] # Identification labels +int interactive # Interactive? + +extern igs_solve1() + +begin + call igs_fit (sf, gp, gplog, gt, axis, pts, npts, labels, interactive, + igs_solve1) +end + + +# IGS_FIT2 -- Fit z = x + f(y) + +procedure igs_fit2 (sf, gp, gplog, gt, axis, pts, npts, labels, interactive) + +pointer sf # GSURFIT pointer +pointer gp # GIO pointer +pointer gplog # GIO pointer for plot log +pointer gt # GTOOLS pointer +int axis[2] # Axis definitions +real pts[npts, ARB] # Data +int npts # Number of pts points +char labels[SZ_LINE, ARB] # Identification labels +int interactive # Interactive? + +extern igs_solve2() + +begin + call igs_fit (sf, gp, gplog, gt, axis, pts, npts, labels, interactive, + igs_solve2) +end + + +# IGS_FIT3 -- Fit z = y + f(x) + +procedure igs_fit3 (sf, gp, gplog, gt, axis, pts, npts, labels, interactive) + +pointer sf # GSURFIT pointer +pointer gp # GIO pointer +pointer gplog # GIO pointer for plot log +pointer gt # GTOOLS pointer +int axis[2] # Axis definitions +real pts[npts, ARB] # Data +int npts # Number of pts points +char labels[SZ_LINE, ARB] # Identification labels +int interactive # Interactive? + +extern igs_solve3() + +begin + call igs_fit (sf, gp, gplog, gt, axis, pts, npts, labels, interactive, + igs_solve3) +end + + +# IGS_FIT -- Interactive surface fitting. + +procedure igs_fit (sf, gp, gplog, gt, axis, pts, npts, labels, interactive, igs_solve) + +pointer sf # GSURFIT pointer +pointer gp # GIO pointer +pointer gplog # GIO pointer for plot log +pointer gt # GTOOLS pointer +int axis[2] # Axis definitions +real pts[npts, ARB] # Data +int npts # Number of pts points +char labels[SZ_LINE, ARB] # Identification labels +int interactive # Interactive? +extern igs_solve() # Surface solution routine + +int i, newgraph, ztype, dtype, refpt, refpt1 +real zval, zval1 +pointer wts + +real wx, wy +int wcs, key +char cmd[SZ_LINE] + +int clgcur(), gt_gcur(), igs_nearest(), igs_nearestd(), igs_nearestu() +errchk igs_solve + +include "igsfit.com" + +begin + # Compute a solution and set the residuals. + + call igs_solve (sf, pts[1,X], pts[1,Y], pts[1,Z], pts[1,W], npts) + call xgsvector (sf, pts[1,X], pts[1,Y], pts[1,S], npts) + call asubr (pts[1,Z], pts[1,S], pts[1,R], npts) + call aavgr (pts[1,R], npts, mean, rms) + call igs_params (gt) + + # Return if not interactive. + + ztype = INDEFI + if ((gp == NULL) || (interactive == NO)) + goto 30 + + call malloc (wts, npts, TY_REAL) + call amovr (pts[1,W], Memr[wts], npts) + + call igs_graph (gp, gt, ztype, refpt, axis, pts, npts, labels) + newgraph = NO + + # Read cursor commands. + +10 while (gt_gcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE) != EOF) { + switch (key) { + case '?': + # Print help text. + + call gpagefile (gp, HELP, PROMPT) + + case ':': + # List or set parameters + + if (cmd[1] == '/') + call gt_colon (cmd, gp, gt, newgraph) + else + call igs_colon (cmd, gp, sf) + + # Set abscissa + + case 'x': + call printf ("Select abscissa (x, y, z, s, r): ") + if (clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE) == EOF) + goto 10 + call printf ("\n") + + switch (key) { + case 'x': + i = X + case 'y': + i = Y + case 'z': + i = Z + case 's': + i = S + case 'r': + i = R + default: + call printf ("\07\n") + goto 10 + } + + if (axis[1] != i) { + axis[1] = i + call gt_setr (gt, GTXMIN, INDEF) + call gt_setr (gt, GTXMAX, INDEF) + } + + # Set ordinate + + case 'y': + call printf ("Select ordinate (x, y, z, s, r): ") + if(clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE) == EOF) + goto 10 + call printf ("\n") + + switch (key) { + case 'x': + i = X + case 'y': + i = Y + case 'z': + i = Z + case 's': + i = S + case 'r': + i = R + default: + call printf ("\07\n") + goto 10 + } + + if (axis[2] != i) { + axis[2] = i + call gt_setr (gt, GTYMIN, INDEF) + call gt_setr (gt, GTYMAX, INDEF) + } + + case 'r': + newgraph = YES + + case 'z': + if (IS_INDEFI (ztype)) { + refpt = igs_nearest (gp, ztype, refpt, axis, pts, npts, wx, + wy, wcs) + + call printf ("Zoom type (x, y, z): ") + if (clgcur ("cursor",wx,wy,wcs,key,cmd,SZ_LINE) == EOF) + goto 10 + call printf ("\n") + + switch (key) { + case 'x': + ztype = X + case 'y': + ztype = Y + case 'z': + ztype = Z + default: + call printf ("\07\n") + goto 10 + } + + newgraph = YES + } + + case 'p': + if (!IS_INDEFI (ztype)) { + ztype = INDEFI + newgraph = YES + } + + case 'l': + if (!IS_INDEFI (ztype)) { + refpt1 = 0 + zval = pts[refpt, ztype] + zval1 = -MAX_REAL + do i = 1, npts { + if ((pts[i,ztype] < zval) && (pts[i,ztype] > zval1)) { + refpt1 = i + zval1 = pts[refpt1,ztype] + } + } + + if (refpt1 != 0) { + refpt = refpt1 + newgraph = YES + } + } + + case 'n': + if (!IS_INDEFI (ztype)) { + refpt1 = 0 + zval = pts[refpt, ztype] + zval1 = MAX_REAL + do i = 1, npts { + if ((pts[i,ztype] > zval) && (pts[i,ztype] < zval1)) { + refpt1 = i + zval1 = pts[refpt1,ztype] + } + } + + if (refpt1 != 0) { + refpt = refpt1 + newgraph = YES + } + } + + case 'c': + # cursor read + i = igs_nearest (gp, ztype, refpt, axis, pts, npts, wx, wy, wcs) + call printf ("%g %g %g %g %g %g\n") + call pargr (pts[i, X]) + call pargr (pts[i, Y]) + call pargr (pts[i, Z]) + call pargr (pts[i, W]) + call pargr (pts[i, S]) + call pargr (pts[i, R]) + + case 'd': + i = igs_nearestd (gp, ztype, refpt, axis, pts, npts, wx, wy, + wcs) + if (i == 0) + goto 10 + + call gscur (gp, real (pts[i,axis[1]]), real (pts[i,axis[2]])) + + call printf ( "Delete 'p'oint or constant 'x', 'y', or 'z': ") + if (clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE) == EOF) + goto 10 + call printf ("\n") + + switch (key) { + case 'p': + dtype = 0 + case 'x': + dtype = X + case 'y': + dtype = Y + case 'z': + dtype = Z + default: + call printf ("\07\n") + goto 10 + } + + call igs_delete (gp, gt, ztype, i, axis, pts, npts, dtype) + + case 'u': + i = igs_nearestu (gp, ztype, refpt, axis, pts, npts, wx, wy, + wcs) + if (i == 0) + goto 10 + + call gscur (gp, real (pts[i,axis[1]]), real (pts[i,axis[2]])) + + call printf ( "Undelete 'p'oint or constant 'x', 'y', or 'z': ") + if (clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE) == EOF) + goto 10 + call printf ("\n") + + switch (key) { + case 'p': + dtype = 0 + case 'x': + dtype = X + case 'y': + dtype = Y + case 'z': + dtype = Z + default: + call printf ("\07\n") + goto 10 + } + + call igs_undelete (gp, gt, ztype, i, axis, pts, Memr[wts], + npts, dtype) + + case 'f': + #call printf ("Fitting ...") + #call flush (STDOUT) + call igs_solve (sf,pts[1,X],pts[1,Y],pts[1,Z],pts[1,W],npts) + call xgsvector (sf, pts[1,X], pts[1,Y], pts[1,S], npts) + call asubr (pts[1,Z], pts[1,S], pts[1,R], npts) + call aavgr (pts[1,R], npts, mean, rms) + call igs_params (gt) + newgraph = YES + + case 'w': + call gt_window (gt, gp, "cursor", newgraph) + + case 'I': + call fatal (0, "Interrupt") + + default: + # Ring the bell. + + call printf ("\07\n") + } + + if (newgraph == YES) { + call igs_graph (gp, gt, ztype, refpt, axis, pts, npts, labels) + newgraph = NO + } + } + + call mfree (wts, TY_REAL) + +30 call igs_graph (gplog, gt, ztype, refpt, axis, pts, npts, labels) + +end diff --git a/noao/twodspec/longslit/transform/igsfit/igsget.x b/noao/twodspec/longslit/transform/igsfit/igsget.x new file mode 100644 index 00000000..ccd1fb6c --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igsget.x @@ -0,0 +1,62 @@ +include <pkg/igsfit.h> + +# IGS_GETI -- Get the value of an integer parameter. + +int procedure igs_geti (param) + +int param # IGS parameter + +include "igsfit.com" + +begin + switch (param) { + case IGS_XORDER: + return (xorder) + case IGS_YORDER: + return (yorder) + default: + call error (0, "igs_geti: Unknown parameter") + } +end + + +# IGS_GETS -- Get the value of a string parameter. + +procedure igs_gets (param, str, maxchar) + +int param # IGS parameter +char str[maxchar] # String +int maxchar # Maximum number of characters + +include "igsfit.com" + +begin + switch (param) { + case IGS_FUNCTION: + call strcpy (function, str, maxchar) + default: + call error (0, "igs_gets: Unknown parameter") + } +end + + +# IGS_GETR -- Get the values of real valued fitting parameters. + +real procedure igs_getr (param) + +int param # Parameter to be get + +include "igsfit.com" + +begin + switch (param) { + case IGS_XMIN: + return (xmin) + case IGS_XMAX: + return (xmax) + case IGS_YMIN: + return (ymin) + case IGS_YMAX: + return (ymax) + } +end diff --git a/noao/twodspec/longslit/transform/igsfit/igsgraph.x b/noao/twodspec/longslit/transform/igsfit/igsgraph.x new file mode 100644 index 00000000..83eba7e1 --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igsgraph.x @@ -0,0 +1,73 @@ +include <mach.h> +include <gset.h> +include <pkg/gtools.h> +include <pkg/igsfit.h> + +procedure igs_graph (gp, gt, ztype, refpt, axis, pts, npts, labels) + +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +int ztype # Zoom type +int refpt # Reference point +int axis[2] # Axis definitions +real pts[npts, ARB] # Data +int npts # Number of pts points +char labels[SZ_LINE, ARB] # Data labels + +int i, x, y +real xmin, xmax, ymin, ymax, xsize, ysize, gt_getr() + +begin + if (gp == NULL) + return + + x = axis[1] + y = axis[2] + + call gt_sets (gt, GTXLABEL, labels[1, x]) + call gt_sets (gt, GTYLABEL, labels[1, y]) + xsize = gt_getr (gt, GTXSIZE) + ysize = gt_getr (gt, GTYSIZE) + + call gclear (gp) + + if (IS_INDEFI (ztype)) { + call gascale (gp, pts[1, x], npts, 1) + call gascale (gp, pts[1, y], npts, 2) + } else { + xmin = MAX_REAL + xmax = -MAX_REAL + ymin = MAX_REAL + ymax = -MAX_REAL + do i = 1, npts { + if (pts[i,ztype] != pts[refpt,ztype]) + next + xmin = min (xmin, pts[i,x]) + xmax = max (xmax, pts[i,x]) + ymin = min (ymin, pts[i,y]) + ymax = max (ymax, pts[i,y]) + } + call gswind (gp, xmin, xmax, ymin, ymax) + } + + call gt_swind (gp, gt) + call gt_labax (gp, gt) + + if (IS_INDEFI (ztype)) { + do i = 1, npts { + if (pts[i,W] == 0.) + call gmark (gp, pts[i,x], pts[i,y], GM_CROSS, xsize, ysize) + else + call gmark (gp, pts[i,x], pts[i,y], GM_PLUS, xsize, ysize) + } + } else { + do i = 1, npts { + if (pts[i,ztype] != pts[refpt,ztype]) + next + if (pts[i,W] == 0.) + call gmark (gp, pts[i,x], pts[i,y], GM_CROSS, xsize, ysize) + else + call gmark (gp, pts[i,x], pts[i,y], GM_PLUS, xsize, ysize) + } + } +end diff --git a/noao/twodspec/longslit/transform/igsfit/igsinit.x b/noao/twodspec/longslit/transform/igsfit/igsinit.x new file mode 100644 index 00000000..f084e7ff --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igsinit.x @@ -0,0 +1,21 @@ +include <pkg/igsfit.h> + +# IGS_INIT -- Initialize the surface fitting parameters. + +procedure igs_init (function, xorder, yorder, xmin, xmax, ymin, ymax) + +char function[ARB] # Function +int xorder # X order +int yorder # Y order +real xmin, xmax # X range +real ymin, ymax # Y range + +begin + call igs_sets (IGS_FUNCTION, function) + call igs_seti (IGS_XORDER, xorder) + call igs_seti (IGS_YORDER, yorder) + call igs_setr (IGS_XMIN, xmin) + call igs_setr (IGS_XMAX, xmax) + call igs_setr (IGS_YMIN, ymin) + call igs_setr (IGS_YMAX, ymax) +end diff --git a/noao/twodspec/longslit/transform/igsfit/igsnearest.x b/noao/twodspec/longslit/transform/igsfit/igsnearest.x new file mode 100644 index 00000000..69888509 --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igsnearest.x @@ -0,0 +1,51 @@ +include <mach.h> +include <gset.h> +include <pkg/igsfit.h> + +int procedure igs_nearest (gp, ztype, refpt, axis, pts, npts, wx, wy, wcs) + +pointer gp # GIO pointer +int ztype # Zoom type +int refpt # Reference point +int axis[2] # Axes +real pts[npts, ARB] # Data points +int npts # Number of data points +real wx, wy # Cursor coordinates +int wcs # WCS + +int i, j, x, y +real r2, r2min, x0, y0 + +begin + x = axis[1] + y = axis[2] + + call gctran (gp, wx, wy, wx, wy, wcs, 0) + r2min = MAX_REAL + j = 0 + + if (IS_INDEFI (ztype)) { + do i = 1, npts { + call gctran (gp, pts[i,x], pts[i,y], x0, y0, wcs, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + } else { + do i = 1, npts { + if (pts[i,ztype] != pts[refpt,ztype]) + next + call gctran (gp, pts[i,x], pts[i,y], x0, y0, wcs, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + } + + call gscur (gp, real (pts[j,x]), real (pts[j,y])) + return (j) +end diff --git a/noao/twodspec/longslit/transform/igsfit/igsparams.x b/noao/twodspec/longslit/transform/igsfit/igsparams.x new file mode 100644 index 00000000..9ecdd422 --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igsparams.x @@ -0,0 +1,23 @@ +include <pkg/gtools.h> + +# IGS_PARAMS -- Set the GTOOLS parameter string. + +procedure igs_params (gt) + +pointer gt # GTOOLS pointer + +pointer params + +include "igsfit.com" + +begin + call malloc (params, SZ_LINE, TY_CHAR) + call sprintf (Memc[params], SZ_LINE, + "Function = %s, xorder = %d, yorder = %d, rms = %.4g") + call pargstr (function) + call pargi (xorder) + call pargi (yorder) + call pargr (rms) + call gt_sets (gt, GTPARAMS, Memc[params]) + call mfree (params, TY_CHAR) +end diff --git a/noao/twodspec/longslit/transform/igsfit/igsset.x b/noao/twodspec/longslit/transform/igsfit/igsset.x new file mode 100644 index 00000000..ea74e8c9 --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igsset.x @@ -0,0 +1,59 @@ +include <pkg/igsfit.h> + +# IGS_SETS -- Set the values of string valued fitting parameters. + +procedure igs_sets (param, str) + +int param # Parameter to be set +char str[ARB] # String value + +include "igsfit.com" + +begin + switch (param) { + case IGS_FUNCTION: + call strcpy (str, function, SZ_LINE) + } +end + + +# IGS_SETI -- Set the values of integer valued fitting parameters. + +procedure igs_seti (param, ival) + +int param # Parameter to be set +int ival # Integer value + +include "igsfit.com" + +begin + switch (param) { + case IGS_XORDER: + xorder = ival + case IGS_YORDER: + yorder = ival + } +end + + +# IGS_SETR -- Set the values of real valued fitting parameters. + +procedure igs_setr (param, rval) + +int param # Parameter to be set +real rval # Real value + +include "igsfit.com" + +begin + switch (param) { + case IGS_XMIN: + xmin = rval + case IGS_XMAX: + xmax = rval + case IGS_YMIN: + ymin = rval + case IGS_YMAX: + ymax = rval + } +end diff --git a/noao/twodspec/longslit/transform/igsfit/igssolve.x b/noao/twodspec/longslit/transform/igsfit/igssolve.x new file mode 100644 index 00000000..a7e39354 --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igssolve.x @@ -0,0 +1,173 @@ +include <math/gsurfit.h> + + +# IGS_SOLVE1 -- Fit z = f(x, y). + +define SFTYPES "|chebyshev|legendre|" # Surface types + +procedure igs_solve1 (sf, x, y, z, w, npts) + +pointer sf # GSURFIT pointer +real x[npts] # X points +real y[npts] # Y points +real z[npts] # Z points +real w[npts] # Weights +int npts # Number of points + +int i, nfunc, ix, iy +pointer sf1, sf2, resids + +int strdic() + +include "igsfit.com" + +begin + # Determine the function type. + + nfunc = strdic (function, function, SZ_LINE, SFTYPES) + + # Fit the first surface. + + ix = min (2, xorder) + iy = min (2, yorder) + call xgsinit (sf1, nfunc, ix, iy, NO, xmin, xmax, ymin, ymax) + call xgsfit (sf1, x, y, z, w, npts, WTS_USER, i) + + switch (i) { + case SINGULAR: + call eprintf ("Singular solution\n") + case NO_DEG_FREEDOM: + call error (0, "No degrees of freedom") + } + + # Evaluate the first surface and fit the residuals. + + call malloc (resids, npts, TY_REAL) + call xgsvector (sf1, x, y, Memr[resids], npts) + call asubr (z, Memr[resids], Memr[resids], npts) + + call xgsinit (sf2, nfunc, xorder, yorder, YES, xmin,xmax,ymin,ymax) + call xgsfit (sf2, x, y, Memr[resids], w, npts, WTS_USER, i) + + switch (i) { + case SINGULAR: + call eprintf ("Singular solution\n") + case NO_DEG_FREEDOM: + call error (0, "No degrees of freedom") + } + + # Add the two surfaces and free memory. + + call xgsadd (sf1, sf2, sf) + call xgsfree (sf1) + call xgsfree (sf2) + call mfree (resids, TY_REAL) +end + + +# IGS_SOLVE2 -- Fit z = x + f(y). + + +procedure igs_solve2 (sf, x, y, z, w, npts) + +pointer sf # GSURFIT pointer +real x[npts] # X points +real y[npts] # Y points +real z[npts] # Z points +real w[npts] # Weights +int npts # Number of points + +int i, nfunc +real a +pointer sf1 + +int strdic() +real xgsgcoeff() + +include "igsfit.com" + +begin + nfunc = strdic (function, function, SZ_LINE, SFTYPES) + call xgsinit (sf1, nfunc, 1, yorder, NO, xmin, xmax, ymin, ymax) + + call asubr (z, x, z, npts) + call xgsfit (sf1, x, y, z, w, npts, WTS_USER, i) + call aaddr (z, x, z, npts) + + switch (i) { + case SINGULAR: + call eprintf ("Singular solution\n") + case NO_DEG_FREEDOM: + call error (0, "No degrees of freedom") + } + + call xgsfree (sf) + call xgsinit (sf, nfunc, 2, yorder, NO, xmin, xmax, ymin, ymax) + a = xgsgcoeff (sf1, 1, 1) + + a = a + (xmin + xmax) / 2 + call xgsscoeff (sf, 1, 1, a) + + a = (xmax - xmin) / 2 + call xgsscoeff (sf, 2, 1, a) + + do i = 2, yorder { + a = xgsgcoeff (sf1, 1, i) + call xgsscoeff (sf, 1, i, a) + } + + call xgsfree (sf1) +end + +# IGS_SOLVE3 -- Fit z = y + f(x). + +procedure igs_solve3 (sf, x, y, z, w, npts) + +pointer sf # GSURFIT pointer +real x[npts] # X points +real y[npts] # Y points +real z[npts] # Z points +real w[npts] # Weights +int npts # Number of points + +int i, nfunc +real a +pointer sf1 + +int strdic() +real xgsgcoeff() + +include "igsfit.com" + +begin + nfunc = strdic (function, function, SZ_LINE, SFTYPES) + call xgsinit (sf1, nfunc, xorder, 1, NO, xmin, xmax, ymin, ymax) + + call asubr (z, y, z, npts) + call xgsfit (sf1, x, y, z, w, npts, WTS_USER, i) + call aaddr (z, y, z, npts) + + switch (i) { + case SINGULAR: + call eprintf ("Singular solution\n") + case NO_DEG_FREEDOM: + call error (0, "No degrees of freedom") + } + + call xgsfree (sf) + call xgsinit (sf, nfunc, xorder, 2, NO, xmin, xmax, ymin, ymax) + a = xgsgcoeff (sf1, 1, 1) + + a = a + (ymin + ymax) / 2 + call xgsscoeff (sf, 1, 1, a) + + a = (ymax - ymin) / 2 + call xgsscoeff (sf, 1, 2, a) + + do i = 2, xorder { + a = xgsgcoeff (sf1, i, 1) + call xgsscoeff (sf, i, 1, a) + } + + call xgsfree (sf1) +end diff --git a/noao/twodspec/longslit/transform/igsfit/igsundelete.x b/noao/twodspec/longslit/transform/igsfit/igsundelete.x new file mode 100644 index 00000000..dc7b802e --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/igsundelete.x @@ -0,0 +1,107 @@ +include <mach.h> +include <gset.h> +include <pkg/gtools.h> +include <pkg/igsfit.h> + +int procedure igs_nearestu (gp, ztype, refpt, axis, pts, npts, wx, wy, wcs) + +pointer gp # GIO pointer +int ztype # Zoom type +int refpt # Reference point +int axis[2] # Axes +real pts[npts, ARB] # Data points +int npts # Number of data points +real wx, wy # Cursor coordinates +int wcs # WCS + +int i, j, x, y +real r2, r2min, x0, y0 + +begin + x = axis[1] + y = axis[2] + + call gctran (gp, wx, wy, wx, wy, wcs, 0) + r2min = MAX_REAL + j = 0 + + if (IS_INDEFI (ztype)) { + do i = 1, npts { + if (pts[i,W] != 0.) + next + call gctran (gp, pts[i, x], pts[i, y], x0, y0, wcs, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + } else { + do i = 1, npts { + if ((pts[i,ztype] != pts[refpt,ztype]) || (pts[i,W] != 0.)) + next + call gctran (gp, pts[i, x], pts[i, y], x0, y0, wcs, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + } + + return (j) +end + + +# IGS_UNDELETE - Undelete point or subset. + +procedure igs_undelete (gp, gt, ztype, refpt, axis, pts, wts, npts, dtype) + +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +int ztype # Zoom type +int refpt # Reference point for undeletion +int axis[2] # Axes +real pts[npts, ARB] # Data points +real wts[npts] # Original weights +int npts # Number of data points +int dtype # Undeletion type + +int i, x, y +real xsize, ysize + +real gt_getr() + +begin + x = axis[1] + y = axis[2] + + xsize = gt_getr (gt, GTXSIZE) + ysize = gt_getr (gt, GTYSIZE) + + switch (dtype) { + case X, Y, Z: + do i = 1, npts { + if (!IS_INDEFI (ztype)) + if (pts[refpt,ztype] != pts[i,ztype]) + next + if (pts[refpt,dtype] != pts[i,dtype]) + next + call gseti (gp, G_PMLTYPE, 0) + call gmark (gp, pts[i,x], pts[i,y], GM_CROSS, xsize, ysize) + call gseti (gp, G_PMLTYPE, 1) + call gmark (gp, pts[i,x], pts[i,y], GM_PLUS, xsize, ysize) + if (wts[i] == 0) + wts[i] = 1 + pts[i,W] = wts[i] + } + default: + call gseti (gp, G_PMLTYPE, 0) + call gmark (gp, pts[refpt,x], pts[refpt,y], GM_CROSS, xsize, ysize) + call gseti (gp, G_PMLTYPE, 1) + call gmark (gp, pts[refpt,x], pts[refpt,y], GM_PLUS, xsize, ysize) + if (wts[refpt] == 0) + wts[refpt] = 1 + pts[refpt,W] = wts[refpt] + } +end diff --git a/noao/twodspec/longslit/transform/igsfit/mkpkg b/noao/twodspec/longslit/transform/igsfit/mkpkg new file mode 100644 index 00000000..ac5a6ca9 --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/mkpkg @@ -0,0 +1,21 @@ +# Interactive General Surface Fitting Package + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +libpkg.a: + igscolon.x igsfit.com <gset.h> + igsdelete.x <gset.h> <mach.h> <pkg/gtools.h> <pkg/igsfit.h> + igsfit.x igsfit.com <mach.h> <pkg/gtools.h> <pkg/igsfit.h> + igsget.x igsfit.com <pkg/igsfit.h> + igsgraph.x <gset.h> <mach.h> <pkg/gtools.h> <pkg/igsfit.h> + igsinit.x <pkg/igsfit.h> + igsnearest.x <gset.h> <mach.h> <pkg/igsfit.h> + igsparams.x igsfit.com <pkg/gtools.h> + igsset.x igsfit.com <pkg/igsfit.h> + igssolve.x igsfit.com <math/gsurfit.h> + igsundelete.x <gset.h> <mach.h> <pkg/gtools.h> <pkg/igsfit.h> + xgs.x <math/gsurfit.h> + ; diff --git a/noao/twodspec/longslit/transform/igsfit/xgs.x b/noao/twodspec/longslit/transform/igsfit/xgs.x new file mode 100644 index 00000000..7d2ea331 --- /dev/null +++ b/noao/twodspec/longslit/transform/igsfit/xgs.x @@ -0,0 +1,243 @@ +include <math/gsurfit.h> + +# XGS -- These routines provide an interface between real input data and +# the double precision surface fitting. Rather than make the input data +# be double precision we only want the internal surface fitting arithmetic +# to be double. But the surface fitting package only provides real +# arithmetic for real input and double precision arithmetic for double +# precision input. Hence these interfaces. Note that the save and restore +# functions use double precision. + +# XGSINIT -- Procedure to initialize the surface descriptor. + +procedure xgsinit (sf, surface_type, xorder, yorder, xterms, xmin, xmax, + ymin, ymax) + +pointer sf # surface descriptor +int surface_type # type of surface to be fitted +int xorder # x order of surface to be fit +int yorder # y order of surface to be fit +int xterms # presence of cross terms +real xmin # minimum value of x +real xmax # maximum value of x +real ymin # minimum value of y +real ymax # maximum value of y + +begin + call dgsinit (sf, surface_type, xorder, yorder, xterms, double (xmin), + double (xmax), double (ymin), double (ymax)) +end + + +# XGSFIT -- Procedure to solve the normal equations for a surface. + +procedure xgsfit (sf, x, y, z, w, npts, wtflag, ier) + +pointer sf # surface descriptor +real x[npts] # array of x values +real y[npts] # array of y values +real z[npts] # data array +real w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +pointer sp, xd, yd, zd, wd +errchk salloc + +begin + call smark (sp) + call salloc (xd, npts, TY_DOUBLE) + call salloc (yd, npts, TY_DOUBLE) + call salloc (zd, npts, TY_DOUBLE) + call salloc (wd, npts, TY_DOUBLE) + call achtrd (x, Memd[xd], npts) + call achtrd (y, Memd[yd], npts) + call achtrd (z, Memd[zd], npts) + call achtrd (w, Memd[wd], npts) + call dgsfit (sf, Memd[xd], Memd[yd], Memd[zd], Memd[wd], npts, + wtflag, ier) + call sfree (sp) +end + + +# XGSVECTOR -- Procedure to evaluate the fitted surface at an array of points. + +procedure xgsvector (sf, x, y, zfit, npts) + +pointer sf # pointer to surface descriptor structure +real x[ARB] # x value +real y[ARB] # y value +real zfit[ARB] # fits surface values +int npts # number of data points + +pointer sp, xd, yd, zd +errchk salloc + +begin + call smark (sp) + call salloc (xd, npts, TY_DOUBLE) + call salloc (yd, npts, TY_DOUBLE) + call salloc (zd, npts, TY_DOUBLE) + call achtrd (x, Memd[xd], npts) + call achtrd (y, Memd[yd], npts) + call dgsvector (sf, Memd[xd], Memd[yd], Memd[zd], npts) + call achtdr (Memd[zd], zfit, npts) + call sfree (sp) +end + + +# XGSEVAL -- Procedure to evaluate the fitted surface at a single point. + +real procedure xgseval (sf, x, y) + +pointer sf # pointer to surface descriptor structure +real x # x value +real y # y value + +double dgseval() + +begin + return (real (dgseval (sf, double (x), double (y)))) +end + + +# XGSADD -- Procedure to add the fits from two surfaces together. + +procedure xgsadd (sf1, sf2, sf3) + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +begin + call dgsadd (sf1, sf2, sf3) +end + + +# XGSFREE -- Procedure to free the surface descriptor + +procedure xgsfree (sf) + +pointer sf # the surface descriptor + +begin + call dgsfree (sf) +end + + +# XGSGCOEFF -- Procedure to fetch a particular coefficient. + +real procedure xgsgcoeff (sf, xorder, yorder) + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent + +double dgsgcoeff() + +begin + return (real (dgsgcoeff (sf, xorder, yorder))) +end + + +# XGSSCOEFF -- Procedure to set a particular coefficient. + +procedure xgsscoeff (sf, xorder, yorder, coeff) + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent +real coeff # Coefficient value + +begin + call dgsscoeff (sf, xorder, yorder, double (coeff)) +end + + +# XGSGETR -- Procedure to fetch a real gsurfit parameter + +real procedure xgsgetr (sf, parameter) + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched + +double dgsgetd() + +begin + return (real (dgsgetd (sf, parameter))) +end + + +# XGSGETI -- Procedure to fetch an integer parameter + +int procedure xgsgeti (sf, parameter) + +pointer sf # pointer to the surface fit +int parameter # integer parameter + +int dgsgeti() + +begin + return (dgsgeti (sf, parameter)) +end + + +# XGSSAVE -- Procedure to save the surface fit for later use by the +# evaluate routines. +# +# NOTE THAT THIS USES DOUBLE PRECISION FOR THE COEFFICIENTS. + +procedure xgssave (sf, fit) + +pointer sf # pointer to the surface descriptor +double fit[ARB] # array for storing fit + +begin + call dgssave (sf, fit) +end + + +# XGSRESTORE -- Procedure to restore the surface fit stored by GSSAVE +# to the surface descriptor for use by the evaluating routines. +# +# NOTE THAT THIS USES DOUBLE PRECISION FOR THE COEFFICIENTS. + +procedure xgsrestore (sf, fit) + +pointer sf # surface descriptor +double fit[ARB] # array containing the surface parameters and + +begin + call dgsrestore (sf, fit) +end + + +# XGSDER -- Procedure to calculate a new surface which is a derivative of +# the previous surface + +procedure xgsder (sf1, x, y, zfit, npts, nxd, nyd) + +pointer sf1 # pointer to the previous surface +real x[npts] # x values +real y[npts] # y values +real zfit[npts] # fitted values +int npts # number of points +int nxd, nyd # order of the derivatives in x and y + +pointer sp, xd, yd, zd + +begin + call smark (sp) + call salloc (xd, npts, TY_DOUBLE) + call salloc (yd, npts, TY_DOUBLE) + call salloc (zd, npts, TY_DOUBLE) + call achtrd (x, Memd[xd], npts) + call achtrd (y, Memd[yd], npts) + call dgsder (sf1, Memd[xd], Memd[yd], Memd[zd], npts, nxd, nyd) + call achtdr (Memd[zd], zfit, npts) + call sfree (sp) +end diff --git a/noao/twodspec/longslit/transform/mkpkg b/noao/twodspec/longslit/transform/mkpkg new file mode 100644 index 00000000..8ea1b584 --- /dev/null +++ b/noao/twodspec/longslit/transform/mkpkg @@ -0,0 +1,20 @@ +# Coordinate Transformation Tasks + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + @igsfit + + fcdbio.x <error.h> <math/gsurfit.h> <pkg/dttext.h> <units.h> + fcdlist.x <error.h> <mach.h> + fcfitcoords.x <pkg/gtools.h> <pkg/igsfit.h> <pkg/xtanswer.h> + fcgetcoords.x <imio.h> <mach.h> <pkg/dttext.h> <pkg/igsfit.h> + fcgetim.x + fitcoords.x <error.h> <pkg/igsfit.h> <pkg/xtanswer.h> + trsetup.x <math.h> <math/gsurfit.h> <math/iminterp.h> + t_fceval.x + t_transform.x transform.com <imhdr.h> <math/iminterp.h> <units.h> + ; diff --git a/noao/twodspec/longslit/transform/t_fceval.x b/noao/twodspec/longslit/transform/t_fceval.x new file mode 100644 index 00000000..a9c5cc75 --- /dev/null +++ b/noao/twodspec/longslit/transform/t_fceval.x @@ -0,0 +1,107 @@ +# T_FCEVAL -- Evaluate FITCOORDS solutions. +# Input consists of a text file of pixel coordinates to be evaluated and the +# user coordinate surfaces from FITCOORDS. The output is a text file of the +# input coordinates followed by the output coordinates. When there is no fit +# for an axis the unit transformation is used and when there is more than one +# fit for an axis the average is used. + +procedure t_fceval () + +pointer input # File of input coordinates +pointer output # File of output coordinates +int fitnames # List of user coordinate fits +pointer database # Database + +int i, j, in, out, nsf[2] +double x[2], y[2] +pointer sp, fitname, sf[2], un[2], sf1, un1 + +bool un_compare() +int open(), fscan(), nscan() +int clpopnu(), clplen(), clgfil() +double dgseval() +errchk open, lm_dbread + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (fitname, SZ_FNAME, TY_CHAR) + + # Get parameters. + call clgstr ("input", Memc[input], SZ_FNAME) + call clgstr ("output", Memc[output], SZ_FNAME) + fitnames = clpopnu ("fitnames") + call clgstr ("database", Memc[database], SZ_FNAME) + + # Open the input and output files. + in = open (Memc[input], READ_ONLY, TEXT_FILE) + out = open (Memc[output], NEW_FILE, TEXT_FILE) + + # Read the solutions. + i = max (1, clplen (fitnames)) + call salloc (sf[1], i, TY_INT) + call salloc (sf[2], i, TY_INT) + + nsf[1] = 0; nsf[2] = 0; un[1] = NULL; un[2] = NULL + while (clgfil (fitnames, Memc[fitname], SZ_FNAME) != EOF) { + call lm_dbread (Memc[database], Memc[fitname], j, un1, sf1) + if (un1 != NULL) { + if (un[j] == NULL) + un[j] = un1 + else if (un_compare (un1, un[j])) + call un_close (un1) + else + call error (1, "Input units disagree") + } + + if (sf1 != NULL) { + Memi[sf[j]+nsf[j]] = sf1 + nsf[j] = nsf[j] + 1 + } + } + + if (nsf[1] + nsf[2] == 0) + call error (0, "No user coordinates") + + # Evaluate the fits at each input coordinate. + while (fscan (in) != EOF) { + call gargd (x[1]) + call gargd (x[2]) + if (nscan() != 2) + next + + do j = 1, 2 { + if (nsf[j] == 0) + y[j] = x[j] + else { + y[j] = dgseval (Memi[sf[j]], x[1], x[2]) + do i = 2, nsf[1] + y[j] = y[j] + dgseval (Memi[sf[j]+i-1], x[1], y[2]) + y[j] = y[j] / nsf[j] + } + } + + call fprintf (out, "%g %g %g %g\n") + call pargd (x[1]) + call pargd (x[2]) + call pargd (y[1]) + call pargd (y[2]) + call flush (out) + } + + # Free the surfaces and units structures. + do j = 1, 2 { + for (i=1; i<=nsf[j]; i=i+1) + call dgsfree (Memi[sf[j]+i-1]) + if (un[j] != NULL) + call un_close (un[j]) + } + + # Finish up. + call clpcls (fitnames) + call close (out) + call close (in) + call sfree (sp) +end diff --git a/noao/twodspec/longslit/transform/t_transform.x b/noao/twodspec/longslit/transform/t_transform.x new file mode 100644 index 00000000..5610858e --- /dev/null +++ b/noao/twodspec/longslit/transform/t_transform.x @@ -0,0 +1,741 @@ +include <imhdr.h> +include <math/iminterp.h> +include <units.h> + +define ITYPES "|nearest|linear|poly3|poly5|spline3|" + +# T_TRANSFORM -- Transform longslit images. +# Input consists of images to be transformed, the user coordinate surfaces +# describing the output coordinates in terms of the input coordinates, +# and the desired coordinates for the output images. The type of image +# interpolation is also input. There is a log output as well as the +# transformed images. The output image may replace the input image. + +procedure t_transform () + +int input # List of input images +int output # List of output images +int minput # List of input masks +int moutput # List of output masks +int fitnames # List of user coordinate fits +pointer database # Database +char interp[10] # Interpolation type +int logfiles # List of log files + +int itypes[II_NTYPES2D], logfd, nusf, nvsf +pointer in, out, pmin, pmout +pointer un[2], mw, ct, usf, vsf, xmsi, ymsi, jmsi, xout, yout, dxout, dyout +pointer sp, image1, image2, image3, minname, moutname, mname, str + +int clpopnu(), clgfil(), clplen(), clgeti(), clgwrd(), open() +int imtopenp(), imtlen(), imtgetim() +bool clgetb() +real clgetr() +pointer immap(), mw_openim(), yt_mappm() +errchk tr_gsf, tr_setup, open, mw_openim, yt_mappm + +data itypes /II_BINEAREST, II_BILINEAR, II_BIPOLY3, II_BIPOLY5, + II_BISPLINE3, II_SINC, II_LSINC, II_DRIZZLE/ + +include "transform.com" + + +begin + call smark (sp) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (image3, SZ_FNAME, TY_CHAR) + call salloc (minname, SZ_FNAME, TY_CHAR) + call salloc (moutname, SZ_FNAME, TY_CHAR) + call salloc (mname, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get and error check the input and output image lists and the other + # task parameters. + + input = imtopenp ("input") + output = imtopenp ("output") + if (imtlen (input) != imtlen (output)) { + call imtclose (input) + call imtclose (output) + call error (1, "Number of input and output images differ") + } + minput = imtopenp ("minput") + moutput = imtopenp ("moutput") + if (imtlen (minput) > 1 && imtlen (minput) != imtlen (input)) { + call imtclose (input) + call imtclose (output) + call imtclose (minput) + call imtclose (moutput) + call error (1, "Can't associate input masks with input images") + } + if (imtlen (moutput) > 0 && imtlen (input) != imtlen (moutput)) { + call imtclose (input) + call imtclose (output) + call imtclose (minput) + call imtclose (moutput) + call error (1, "Number output masks differ from input") + } + + fitnames = clpopnu ("fitnames") + call clgstr ("database", Memc[database], SZ_FNAME) + itype = itypes[clgwrd ("interptype", interp, 10, II_FUNCTIONS)] + logfiles = clpopnu ("logfiles") + + u1 = clgetr ("x1") + u2 = clgetr ("x2") + du = clgetr ("dx") + nu = clgeti ("nx") + v1 = clgetr ("y1") + v2 = clgetr ("y2") + dv = clgetr ("dy") + nv = clgeti ("ny") + + ulog = clgetb ("xlog") + vlog = clgetb ("ylog") + flux = clgetb ("flux") + blank = clgetr ("blank") + + usewcs = (clplen (fitnames) == 0) + + # Transform each input image to the output image. + Memc[minname] = EOS + Memc[moutname] = EOS + Memc[mname] = EOS + xmsi = NULL + while ((imtgetim (input, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (output, Memc[image2], SZ_FNAME) != EOF)) { + + # Get mask names. + if (imtgetim (minput, Memc[image3], SZ_FNAME) != EOF) + call strcpy (Memc[image3], Memc[minname], SZ_FNAME) + if (imtgetim (moutput, Memc[image3], SZ_FNAME) != EOF) + call strcpy (Memc[image3], Memc[moutname], SZ_FNAME) + + # Map the input and output images. + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[image3],SZ_FNAME) + in = immap (Memc[image1], READ_ONLY, 0) + out = immap (Memc[image2], NEW_COPY, in) + + # Map masks. + pmin = NULL; pmout = NULL + if (Memc[minname] != EOS) + pmin = yt_mappm (Memc[minname], in, "logical", Memc[mname], + SZ_FNAME) + if (Memc[moutname] != EOS) { + call xt_maskname (Memc[moutname], "", NEW_IMAGE, + Memc[moutname], SZ_FNAME) + pmout = immap (Memc[moutname], NEW_COPY, in) + call imastr (out, "BPM", Memc[moutname]) + } + + # Get the coordinate transformation surfaces from the database + # and setup the transformations. + # Do this only on the first pass. + + if (xmsi == NULL) { + if (usewcs) { + mw = mw_openim (in) + call tr_gwcs (mw, un, IM_LEN(in,1), IM_LEN(in,2), ct, + usf, nusf, vsf, nvsf) + } else { + mw = NULL + ct = NULL + call tr_gsf (Memc[database], fitnames, un, usf, nusf, + vsf, nvsf) + } + call tr_setup (ct, usf, nusf, vsf, nvsf, un, xmsi, ymsi, jmsi, + xout, yout, dxout, dyout) + if (mw != NULL) + call mw_close (mw) + } + + # Write log information. + while (clgfil (logfiles, Memc[str], SZ_LINE) != EOF) { + logfd = open (Memc[str], APPEND, TEXT_FILE) + call sysid (Memc[str], SZ_LINE) + call fprintf (logfd, "\n%s\n") + call pargstr (Memc[str]) + call fprintf (logfd, " Transform %s to %s.\n") + call pargstr (Memc[image1]) + call pargstr (Memc[image3]) + if (pmout != EOS) { + if (pmin != EOS) { + call fprintf (logfd, " Transform mask %s to %s.\n") + call pargstr (Memc[mname]) + call pargstr (Memc[moutname]) + } else { + call fprintf (logfd, " Output mask is %s.\n") + call pargstr (Memc[moutname]) + } + } + if (flux) + call fprintf (logfd, " Conserve flux per pixel.\n") + if (usewcs) + call fprintf (logfd, " Transforming using image WCS.\n") + else { + call fprintf (logfd, " User coordinate transformations:\n") + while (clgfil (fitnames, Memc[str], SZ_LINE) != EOF) { + call fprintf (logfd, " %s\n") + call pargstr (Memc[str]) + } + } + call fprintf (logfd, " Interpolation is %s.\n") + call pargstr (interp) + if (!IS_INDEFR(blank)) { + call fprintf (logfd, " Out of bounds pixel value is %g.\n") + call pargr (blank) + } else + call fprintf (logfd, + " Using edge extension for out of bounds pixel values.\n") + call fprintf (logfd, " Output coordinate parameters are:\n") + call fprintf (logfd, + " x1 = %10.4g, x2 = %10.4g, dx = %10.4g, nx = %4d, xlog = %b\n") + call pargr (u1) + call pargr (u2) + call pargr (du) + call pargi (nu) + call pargb (ulog) + call fprintf (logfd, + " y1 = %10.4g, y2 = %10.4g, dy = %10.4g, ny = %4d, ylog = %b\n") + call pargr (v1) + call pargr (v2) + call pargr (dv) + call pargi (nv) + call pargb (vlog) + call close (logfd) + } + call clprew (logfiles) + + call tr_transform (in, out, pmin, pmout, un, xmsi, ymsi, jmsi, + Memr[xout], Memr[yout], Memr[dxout], Memr[dyout]) + + if (pmout != NULL) + call imunmap (pmout) + if (pmin != NULL) + call xt_pmunmap (pmin) + call imunmap (in) + call imunmap (out) + call xt_delimtemp (Memc[image2], Memc[image3]) + + if (usewcs) { + call mfree (xout, TY_REAL) + call mfree (yout, TY_REAL) + call mfree (dxout, TY_REAL) + call mfree (dyout, TY_REAL) + if (xmsi != NULL) + call msifree (xmsi) + if (ymsi != NULL) + call msifree (ymsi) + if (jmsi != NULL) + call msifree (jmsi) + if (un[1] != NULL) + call un_close (un[1]) + if (un[2] != NULL) + call un_close (un[2]) + xmsi = NULL + } + + } + + call mfree (xout, TY_REAL) + call mfree (yout, TY_REAL) + call mfree (dxout, TY_REAL) + call mfree (dyout, TY_REAL) + if (xmsi != NULL) + call msifree (xmsi) + if (ymsi != NULL) + call msifree (ymsi) + if (jmsi != NULL) + call msifree (jmsi) + if (un[1] != NULL) + call un_close (un[1]) + if (un[2] != NULL) + call un_close (un[2]) + call imtclose (minput) + call imtclose (moutput) + call imtclose (input) + call imtclose (output) + call clpcls (fitnames) + call clpcls (logfiles) + call sfree (sp) +end + + +# TR_SETOUTPUT -- Set the output coordinates in the common block. +# This procedure allows the user to specifying a part of the output +# coordinates and let the rest default based on the full limits of +# the user coordinate surfaces. + +procedure tr_setoutput (xmin, xmax, ymin, ymax, umin, umax, vmin, vmax) + +real xmin, xmax, ymin, ymax +real umin, umax, vmin, vmax + +int nua, nva +real u1a, u2a, dua, v1a, v2a, dva + +include "transform.com" + +begin + # Save the original values of the user parameters. + u1a = u1 + u2a = u2 + dua = du + nua = nu + v1a = v1 + v2a = v2 + dva = dv + nva = nv + + # If the output coordinate limits are not defined then use the + # transformation surface limits. + + if (IS_INDEF (u1)) + u1 = umin + if (IS_INDEF (u2)) + u2 = umax + if (IS_INDEF (v1)) + v1 = vmin + if (IS_INDEF (v2)) + v2 = vmax + + # If the number of output pixels are not defined then use the number + # of pixels in the input image. + + if (IS_INDEFI (nu)) + nu = xmax - xmin + 1 + if (IS_INDEFI (nv)) + nv = ymax - ymin + 1 + + # If the coordinate interval is not defined determine it from the + # number of pixels and the coordinate limits. If the interval is + # defined then override the number of pixels. + + if (ulog) { + if (IS_INDEF (du)) + du = (log10 (u2) - log10 (u1)) / (nu - 1) + else if (IS_INDEFI (nua)) + nu = nint ((log10 (u2) - log10 (u1)) / du + 1) + else if (IS_INDEF (u1a)) + u1 = 10.0 ** (log10 (u2) - du * (nu - 1)) + else + u2 = 10.0 ** (log10 (u1) + du * (nu - 1)) + } else { + if (IS_INDEF (du)) + du = (u2 - u1) / (nu - 1) + else if (IS_INDEFI (nua)) + nu = nint ((u2 - u1) / du + 1) + else if (IS_INDEF (u1a)) + u1 = u2 - du * (nu - 1) + else + u2 = u1 + du * (nu - 1) + } + + if (vlog) { + if (IS_INDEF (dv)) + dv = (log10 (v2) - log10 (v1)) / (nv - 1) + else if (IS_INDEFI (nva)) + nv = nint ((log10 (v2) - log10 (v1)) / dv + 1) + else if (IS_INDEF (v1a)) + v1 = 10.0 ** (log10 (v2) - dv * (nv - 1)) + else + v2 = 10.0 ** (log10 (v1) + dv * (nv - 1)) + } else { + if (IS_INDEF (dv)) + dv = (v2 - v1) / (nv - 1) + else if (IS_INDEFI (nva)) + nv = nint ((v2 - v1) / dv + 1) + else if (IS_INDEF (v1a)) + v1 = v2 - dv * (nv - 1) + else + v2 = v1 + dv * (nv - 1) + } +end + + +define NBUF 16 # Additional buffer for interpolation +define NEDGE 2 # Number of edge lines to add for interpolation +define MINTERP 100 # Mask value for input mask interpolation +define MTHRESH 10 # Interpolated mask value for bad pixels +define MBAD 1 # Mask value for output bad pixels +define MBLANK 1 # Mask value for out of bounds pixels + +# TR_TRANSFORM -- Perform the image transformation using a user specified +# image interpolator. If an input and output mask are included the input +# mask values are set to MINTERP, interpolated in the same way, and any values +# greater than MTHRESH are set to MBAD. Note that currently the input mask +# values are not used in computing the input data interpolation value. +# The masks MUST be the same size as the input data and are assumed to +# be registered in logical pixel coordinates. + +procedure tr_transform (in, out, pmin, pmout, un, xmsi, ymsi, jmsi, xout, yout, + dxout, dyout) + +pointer in, out #I IMIO data pointers +pointer pmin, pmout #I IMIO mask pointers (NULL if not used) +pointer un[2] #I Units +pointer xmsi, ymsi #I Coordinate interpolation pointers +pointer jmsi #I Jacobian interpolation pointer +real xout[ARB], yout[ARB] #I Output grid relative to interpolation surface +real dxout[ARB], dyout[ARB] #I Output coordinate intervals + +int i, j, nxin, nyin, line1, line2, line3, line4, nlines, laxis, paxis +bool xofb, yofb +real a, b, c, r[2], w[2], cd[2,2] +pointer zmsi, mzmsi, buf, mbuf, bufout +pointer sp, xin, yin, jbuf, xin1, yin1, y, mw + +pointer mw_open(), impl2r() +errchk get_daxis + +include "transform.com" + +begin + # Initialize the output image header. + + IM_LEN(out, 1) = nu + IM_LEN(out, 2) = nv + if (pmout != NULL) { + IM_LEN(pmout, 1) = nu + IM_LEN(pmout, 2) = nv + } + + mw = mw_open (NULL, 2) + call mw_newsystem (mw, "world", 2) + do i = 1, 2 { + call mw_swtype (mw, i, 1, "linear", "") + if (un[i] != NULL) { + call mw_swattrs (mw, i, "label", UN_LABEL(un[i])) + call mw_swattrs (mw, i, "units", UN_UNITS(un[i])) + } + } + + r[1] = 1. + if (ulog) + w[1] = log10 (u1) + else + w[1] = u1 + cd[1,1] = du + cd[1,2] = 0. + r[2] = 1. + if (vlog) + w[2] = log10 (v1) + else + w[2] = v1 + cd[2,2] = dv + cd[2,1] = 0. + call mw_swtermr (mw, r, w, cd, 2) + + # The following image parameters are for compatibility with the + # ONEDSPEC package if using database solutions. + + if (!usewcs) { + call imastr (out, "DCLOG1", "Transform") + iferr (call imdelf (out, "REFSPEC1")) + ; + iferr (call imdelf (out, "REFSPEC2")) + ; + call get_daxis (in, laxis, paxis) + call imaddi (out, "dispaxis", laxis) + switch (laxis) { + case 1: + if (ulog) + call imaddi (out, "dc-flag", 1) + else + call imaddi (out, "dc-flag", 0) + if (un[laxis] == NULL) { + call mw_swattrs (mw, laxis, "label", "Wavelength") + call mw_swattrs (mw, laxis, "units", "Angstroms") + } + case 2: + if (vlog) + call imaddi (out, "dc-flag", 1) + else + call imaddi (out, "dc-flag", 0) + if (un[laxis] == NULL) { + call mw_swattrs (mw, laxis, "label", "Wavelength") + call mw_swattrs (mw, laxis, "units", "Angstroms") + } + } + } + call mw_saveim (mw, out) + if (pmout != NULL) + call mw_saveim (mw, pmout) + call mw_close (mw) + + # Allocate memory for the input coordinates and a vector for the + # output y coordinates. Also initialize the image data buffer. + + call smark (sp) + call salloc (xin, nu, TY_REAL) + call salloc (yin, nu, TY_REAL) + call salloc (y, nu, TY_REAL) + if (flux) + call salloc (jbuf, nu, TY_REAL) + if (!IS_INDEFR(blank) || pmout != NULL) { + call salloc (xin1, nu, TY_REAL) + call salloc (yin1, nu, TY_REAL) + } + + buf = NULL + mbuf = NULL + nlines = 0 + + # Initialize the interpolator. + + call msiinit (zmsi, itype) + if (pmin != NULL) + call msiinit (mzmsi, itype) + + # Do each line of the output image. + + nxin = IM_LEN(in, 1) + nyin = IM_LEN(in, 2) + + do i = 1, nv { + + # Evaluate the input coordinates at the output grid for a line + # of the output image using the interpolation surfaces. + + call amovkr (yout[i], Memr[y], nu) + if (!IS_INDEFR(blank) || pmout != NULL) { + call msivector (xmsi, xout, Memr[y], Memr[xin1], nu) + call msivector (ymsi, xout, Memr[y], Memr[yin1], nu) + call amovr (Memr[xin1], Memr[xin], nu) + call amovr (Memr[yin1], Memr[yin], nu) + } else { + call msivector (xmsi, xout, Memr[y], Memr[xin], nu) + call msivector (ymsi, xout, Memr[y], Memr[yin], nu) + } + + # Determine the coordinate ranges and check for out of bounds. + + call alimr (Memr[xin], nu, a, b) + xofb = (a < 1 || b > nxin) + if (xofb) { + if (a < 1) + call arltr (Memr[xin], nu, 1., 1.) + if (b > nxin) + call argtr (Memr[xin], nu, real (nxin), real (nxin)) + } + + call alimr (Memr[yin], nu, a, b) + yofb = (a < 1 || b > nyin) + if (yofb) { + if (a < 1) { + call arltr (Memr[yin], nu, 1., 1.) + a = 1. + b = max (a, b) + } + if (b > nyin) { + call argtr (Memr[yin], nu, real (nyin), real (nyin)) + b = nyin + a = min (a, b) + } + } + + # Get the input image data and fit an interpolator to the data. + + if ((buf == NULL) || (b > line2) || (a < line1)) { + nlines = max (nlines, int (b - a + 2 + NBUF)) + if (buf == NULL) { + if (a < nyin / 2) { + line1 = max (1, int (a)) + line2 = min (nyin, line1 + nlines - 1) + } else { + line2 = min (nyin, int (b+1.)) + line1 = max (1, line2 - nlines + 1) + } + } else if (b > line2) { + line1 = max (1, int (a)) + line2 = min (nyin, line1 + nlines - 1) + line1 = max (1, line2 - nlines + 1) + } else { + line2 = min (nyin, int (b+1.)) + line1 = max (1, line2 - nlines + 1) + line2 = min (nyin, line1 + nlines - 1) + } + line3 = max (1, line1 - NEDGE) + line4 = min (nyin, line2 + NEDGE) + call tr_bufl2r (in, pmin, line3, line4, buf, mbuf) + call msifit (zmsi, Memr[buf], nxin, line4 - line3 + 1, nxin) + if (pmin != NULL) + call msifit (mzmsi, Memr[mbuf], nxin, line4 - line3 + 1, + nxin) + } + + # The input coordinates must be offset to interpolation data grid. + call asubkr (Memr[yin], real (line3 - 1), Memr[yin], nu) + + # Evaluate output image pixels, conserve flux (if requested) using + # the Jacobian, and set the out of bounds values. + + bufout = impl2r (out, i) + call msivector (zmsi, Memr[xin], Memr[yin], Memr[bufout], nu) + if (flux) { + call msivector (jmsi, xout, Memr[y], Memr[jbuf], nu) + call amulr (dxout, Memr[jbuf], Memr[jbuf], nu) + call amulkr (Memr[jbuf], dyout[i], Memr[jbuf], nu) + call amulr (Memr[bufout], Memr[jbuf], Memr[bufout], nu) + } + if (!IS_INDEFR(blank)) { + if (xofb) { + do j = 0, nu-1 { + if (Memr[xin1+j] < 1 || Memr[xin1+j] > nxin) + Memr[bufout+j] = blank + } + } + if (yofb) { + do j = 0, nu-1 { + if (Memr[yin1+j] < 1 || Memr[yin1+j] > nyin) + Memr[bufout+j] = blank + } + } + } + + # Evaluate output mask pixels and set output bad values. + + if (pmout != NULL) { + bufout = impl2r (pmout, i) + if (pmin != NULL) { + call msivector (mzmsi, Memr[xin], Memr[yin], Memr[bufout], + nu) + do j = 0, nu-1 { + c = Memr[bufout+j] + if (Memr[xin1+j] < 1 || Memr[xin1+j] > nxin || + Memr[yin1+j] < 1 || Memr[yin1+j] > nyin) + Memr[bufout+j] = MBLANK + else if (c > 0.) { + if (c > MTHRESH) + Memr[bufout+j] = MBAD + else + Memr[bufout+j] = 0 + } + } + } else { + call aclrr (Memr[bufout], nu) + if (xofb) { + do j = 0, nu-1 { + if (Memr[xin1+j] < 1 || Memr[xin1+j] > nxin) + Memr[bufout+j] = MBLANK + } + } + if (yofb) { + do j = 0, nu-1 { + if (Memr[yin1+j] < 1 || Memr[yin1+j] > nyin) + Memr[bufout+j] = MBLANK + } + } + } + } + } + + # Free memory. + + call mfree (buf, TY_REAL) + call mfree (mbuf, TY_REAL) + call msifree (zmsi) + if (pmin != NULL) + call msifree (mzmsi) + call sfree (sp) +end + + +# TR_BUFL2R -- Maintain buffer of image lines. A new buffer is created when +# the buffer pointer is null or if the number of lines requested is changed. +# The minimum number of image reads is used. + +procedure tr_bufl2r (im, pmin, line1, line2, buf, mbuf) + +pointer im #I Image pointer +pointer pmin #I Mask pointer +int line1 #I First image line of buffer +int line2 #I Last image line of buffer +pointer buf #U Output data buffer +pointer mbuf #U Output mask buffer + +int i, nlines, nx, last1, last2, nlast +pointer buf1, buf2 + +pointer imgl2r() + +begin + nlines = line2 - line1 + 1 + + # If the buffer pointer is undefined then allocate memory for the + # buffer. If the number of lines requested changes reallocate + # the buffer. Initialize the last line values to force a full + # buffer image read. + + if (buf == NULL) { + nx = IM_LEN(im, 1) + call malloc (buf, nx * nlines, TY_REAL) + if (pmin != NULL) + call malloc (mbuf, nx * nlines, TY_REAL) + last1 = line1 - nlines + last2 = line2 - nlines + } else if (nlines != nlast) { + call realloc (buf, nx * nlines, TY_REAL) + if (pmin != NULL) + call realloc (mbuf, nx * nlines, TY_REAL) + last1 = line1 - nlines + last2 = line2 - nlines + } + + # Read only the image lines with are different from the last buffer. + + if (line1 < last1) { + do i = line2, line1, -1 { + if (i > last1) + buf1 = buf + (i - last1) * nx + else + buf1 = imgl2r (im, i) + + buf2 = buf + (i - line1) * nx + call amovr (Memr[buf1], Memr[buf2], nx) + } + } else if (line2 > last2) { + do i = line1, line2 { + if (i < last2) + buf1 = buf + (i - last1) * nx + else + buf1 = imgl2r (im, i) + + buf2 = buf + (i - line1) * nx + call amovr (Memr[buf1], Memr[buf2], nx) + } + } + if (pmin != NULL) { + if (line1 < last1) { + do i = line2, line1, -1 { + if (i > last1) + buf1 = mbuf + (i - last1) * nx + else + buf1 = imgl2r (pmin, i) + + buf2 = mbuf + (i - line1) * nx + call amovr (Memr[buf1], Memr[buf2], nx) + call argtr (Memr[buf2], nx, 0.1, real(MINTERP)) + } + } else if (line2 > last2) { + do i = line1, line2 { + if (i < last2) + buf1 = mbuf + (i - last1) * nx + else + buf1 = imgl2r (pmin, i) + + buf2 = mbuf + (i - line1) * nx + call amovr (Memr[buf1], Memr[buf2], nx) + call argtr (Memr[buf2], nx, 0.1, real(MINTERP)) + } + } + } + + # Save the buffer parameters. + + last1 = line1 + last2 = line2 + nlast = nlines +end diff --git a/noao/twodspec/longslit/transform/transform.com b/noao/twodspec/longslit/transform/transform.com new file mode 100644 index 00000000..baaae3ab --- /dev/null +++ b/noao/twodspec/longslit/transform/transform.com @@ -0,0 +1,14 @@ +# TRANSFORM -- Common task parameters. + +int itype # Interpolation type +real u1, v1 # Starting coordinates +real u2, v2 # Ending coordinates +real du, dv # Coordinate intervals +int nu, nv # Number of pixels +bool ulog, vlog # Logrithmic coordinates? +bool flux # Conserve flux per pixel? +bool usewcs # Use WCS? +real blank # Blank value + +common /trcom/ u1, v1, u2, v2, du, dv, nu, nv, itype, ulog, vlog, + flux, usewcs, blank diff --git a/noao/twodspec/longslit/transform/trsetup.x b/noao/twodspec/longslit/transform/trsetup.x new file mode 100644 index 00000000..72db570d --- /dev/null +++ b/noao/twodspec/longslit/transform/trsetup.x @@ -0,0 +1,663 @@ +include <math.h> +include <math/gsurfit.h> +include <math/iminterp.h> + +# Wrapper for MWCS CT pointer to include the image pixel range. + +define CT_LW Memi[$1] # MWCS CT (logical -> world) +define CT_WL Memi[$1+1] # MWCS CT (world -> logical) +define CT_NX Memi[$1+2] # Number of pixels in X +define CT_NY Memi[$1+3] # Number of pixels Y + + +# TR_GSF -- Get coordinate surface fits from the database. + +procedure tr_gsf (database, sflist, un, usf, nusf, vsf, nvsf) + +char database #I Database containing coordinate surfaces +int sflist #I List of user coordinate surfaces +pointer un[2] #O Units pointers +pointer usf #O Pointer to array of U surface fits +int nusf #O Number of U surface fits +pointer vsf #O Pointer to array of V surface fits +int nvsf #O Number of U surface fits + +int i, nsf +pointer sp, sfname, un1, sf + +bool un_compare() +int clgfil(), clplen() + +begin + # Get the user coordinate surfaces and separate them into U and V. + # Check that all surfaces have the same range of X and Y and determine + # the range of U and V. + + call smark (sp) + call salloc (sfname, SZ_FNAME, TY_CHAR) + + nsf = max (1, clplen (sflist)) + call malloc (usf, nsf, TY_INT) + call malloc (vsf, nsf, TY_INT) + + un[1] = NULL + un[2] = NULL + Memi[usf] = NULL + Memi[vsf] = NULL + nusf = 0 + nvsf = 0 + while (clgfil (sflist, Memc[sfname], SZ_FNAME) != EOF) { + call lm_dbread (database, Memc[sfname], i, un1, sf) + if (un1 != NULL) { + if (un[i] == NULL) + un[i] = un1 + else if (un_compare (un1, un[i])) + call un_close (un1) + else { + call un_close (un1) + call un_close (un[i]) + call sfree (sp) + call error (1, "Input units disagree") + } + } + + if (sf != NULL) { + if (i == 1) { + nusf = nusf+1 + Memi[usf+nusf-1] = sf + } else if (i == 2) { + nvsf = nvsf+1 + Memi[vsf+nvsf-1] = sf + } + } + } + call clprew (sflist) + + if (nusf + nvsf == 0) + call error (0, "No user coordinates") + + call sfree (sp) +end + + +# TR_GWCS -- Get WCS. + +procedure tr_gwcs (mw, un, nx, ny, ct, usf, nusf, vsf, nvsf) + +pointer mw #I MWCS pointer +pointer un[2] #O Units pointers +int nx, ny #I Image size + +pointer ct #O CT pointer +pointer usf #O Pointer to array of U surface fits +int nusf #O Number of U surface fits +pointer vsf #O Pointer to array of V surface fits +int nvsf #O Number of U surface fits + +int i +pointer sp, units, un_open(), mw_sctran() +errchk un_open + +begin + call smark (sp) + call salloc (units, SZ_FNAME, TY_CHAR) + + call malloc (ct, 4, TY_STRUCT) + nusf = 1 + call calloc (usf, nusf, TY_INT) + nvsf = 1 + call calloc (vsf, nvsf, TY_INT) + + CT_LW(ct) = mw_sctran (mw, "logical", "world", 3) + CT_WL(ct) = mw_sctran (mw, "world", "logical", 3) + CT_NX(ct) = nx + CT_NY(ct) = ny + + do i = 1, 2 { + ifnoerr (call mw_gwattrs (mw, i, "units", Memc[units], SZ_FNAME)) + un[i] = un_open (Memc[units]) + else + un[i] = NULL + } +end + + +# TR_SETUP -- Setup the transformation interpolation. +# +# At each point (U,V) in the output image we need to know the coordinate +# (X,Y) of the input images to be interpolated. This means we need +# to determine X(U,V) and Y(U,V). The input user coordinate surfaces, +# however, are U(X,Y) and V(X,Y) (a missing surface implies a one to one +# mapping of U=X or V=Y). This requires simultaneously inverting the user +# coordinate surfaces. This is a slow process using a gradient following +# iterative technique. +# +# Note that when an WCS is used, the MWCS routines already provide the +# inverse mapping. But even in this case it may be slow and so we use the +# same sampling and surface fitting technique for setting up the inversion +# mapping. +# +# The inverted coordinates are determined on a evenly subsampled grid of +# linear output coordinates. A linear interpolation surface can then be fit +# to this grid which is much faster to evaluate at each output coordinate. +# These interpolation surfaces are returned. If flux is to be conserved a +# similar interpolation surface for the Jacobian, J(U,V) is also returned. +# There may also be a mapping of the output image into logrithmic intervals +# which maps to the linearly sampled interpolation surfaces. The mappings +# of the output U and V intervals to the subsampled interpolation coordinates +# are also returned. +# +# 1. Set the output coordinate system based on the ranges of X, Y, U, and V. +# 2. Determine X(U,V), Y(U,V), and J(U,V) on a evenly subsampled grid of +# U and V. +# 3. Fit linear interpolation surfaces to these data. +# 4. Compute the mapping between output coordinates along each axis, which +# may be logrithmic, into the subsampling interpolation coordinates. + +procedure tr_setup (ct, usf, nusf, vsf, nvsf, un, xmsi, ymsi, jmsi, + uout, vout, duout, dvout) + +pointer ct #I CT pointer +pointer usf #U Pointers to U surface fits: freed upon return +int nusf #I Number of U surface fits +pointer vsf #U Pointers to V surface fits: freed upon return +int nvsf #I Number of V surface fits +pointer un[2] #O Units pointers +pointer xmsi, ymsi, jmsi #O Surface interpolators for X, Y and Jacobian +pointer uout, vout #O Output coordinates relative to interpolator +pointer duout, dvout #O Output coordinate intervals + +int i, j, step, nu1, nv1 +real xmin, xmax, ymin, ymax, umin, umax, vmin, vmax +real u, v, x, y, du1, dv1, der[8] +double dval +pointer xgrid, ygrid, zgrid, ptr1, ptr2, ptr3 + +real tr_getr(), tr_eval() + +include "transform.com" + +begin + #step = clgeti ("step") + step = 10 + + xmin = INDEF + xmax = INDEF + ymin = INDEF + ymax = INDEF + umin = INDEF + umax = INDEF + vmin = INDEF + vmax = INDEF + do i = 1, nusf { + if (IS_INDEF (xmin)) { + xmin = tr_getr (ct, Memi[usf+i-1], GSXMIN) + xmax = tr_getr (ct, Memi[usf+i-1], GSXMAX) + ymin = tr_getr (ct, Memi[usf+i-1], GSYMIN) + ymax = tr_getr (ct, Memi[usf+i-1], GSYMAX) + } else { + if ((xmin != tr_getr (ct, Memi[usf+i-1], GSXMIN)) || + (xmax != tr_getr (ct, Memi[usf+i-1], GSXMAX)) || + (ymin != tr_getr (ct, Memi[usf+i-1], GSYMIN)) || + (ymax != tr_getr (ct, Memi[usf+i-1], GSYMAX))) + call error (0, "tr_setup: Inconsistent coordinate fits") + } + + if (IS_INDEF (umin)) { + umin = tr_eval (ct, Memi[usf+i-1], 1, xmin, ymin) + umax = umin + } + u = tr_eval (ct, Memi[usf+i-1], 1, xmin, ymin) + umin = min (u, umin) + umax = max (u, umax) + u = tr_eval (ct, Memi[usf+i-1], 1, xmax, ymin) + umin = min (u, umin) + umax = max (u, umax) + u = tr_eval (ct, Memi[usf+i-1], 1, xmin, ymax) + umin = min (u, umin) + umax = max (u, umax) + u = tr_eval (ct, Memi[usf+i-1], 1, xmax, ymax) + umin = min (u, umin) + umax = max (u, umax) + } + do i = 1, nvsf { + if (IS_INDEF (xmin)) { + xmin = tr_getr (ct, Memi[vsf+i-1], GSXMIN) + xmax = tr_getr (ct, Memi[vsf+i-1], GSXMAX) + ymin = tr_getr (ct, Memi[vsf+i-1], GSYMIN) + ymax = tr_getr (ct, Memi[vsf+i-1], GSYMAX) + } else { + if ((xmin != tr_getr (ct, Memi[vsf+i-1], GSXMIN)) || + (xmax != tr_getr (ct, Memi[vsf+i-1], GSXMAX)) || + (ymin != tr_getr (ct, Memi[vsf+i-1], GSYMIN)) || + (ymax != tr_getr (ct, Memi[vsf+i-1], GSYMAX))) + call error (0, "tr_setup: Inconsistent coordinate fits") + } + + if (IS_INDEF (vmin)) { + vmin = tr_eval (ct, Memi[vsf+i-1], 2, xmin, ymin) + vmax = vmin + } + v = tr_eval (ct, Memi[vsf+i-1], 2, xmin, ymin) + vmin = min (v, vmin) + vmax = max (v, vmax) + v = tr_eval (ct, Memi[vsf+i-1], 2, xmax, ymin) + vmin = min (v, vmin) + vmax = max (v, vmax) + v = tr_eval (ct, Memi[vsf+i-1], 2, xmin, ymax) + vmin = min (v, vmin) + vmax = max (v, vmax) + v = tr_eval (ct, Memi[vsf+i-1], 2, xmax, ymax) + vmin = min (v, vmin) + vmax = max (v, vmax) + } + if (IS_INDEF (umin)) { + umin = xmin + umax = xmax + } + if (IS_INDEF (vmin)) { + vmin = ymin + vmax = ymax + } + + # Set the output coordinate system which is in a common block. + call tr_setoutput (xmin, xmax, ymin, ymax, umin, umax, vmin, vmax) + + # Subsample the inverted coordinates and fit an interpolation + # surface. The grid is evaluated in a back and forth pattern to + # use the last point evaluated and the starting point for the next + # point. This allows the interative inversion routine to work most + # efficiently with typically only two evaluations per step. + + nu1 = max (2, nu / step) + nv1 = max (2, nv / step) + du1 = (u2 - u1) / (nu1 - 1) + dv1 = (v2 - v1) / (nv1 - 1) + + call malloc (xgrid, nu1 * nv1, TY_REAL) + call malloc (ygrid, nu1 * nv1, TY_REAL) + call malloc (zgrid, nu1 * nv1, TY_REAL) + + call tr_init (ct, Memi[usf], nusf, Memi[vsf], nvsf, xmin, ymin, der) + do i = 1, nv1, 2 { + # Do this line from left to right. + ptr1 = xgrid + (i - 1) * nu1 - 1 + ptr2 = ygrid + (i - 1) * nu1 - 1 + ptr3 = zgrid + (i - 1) * nu1 - 1 + v = v1 + (i - 1) * dv1 + do j = 1, nu1 { + u = u1 + (j - 1) * du1 + call tr_invert (ct, Memi[usf], nusf, Memi[vsf], nvsf, u, v, + x, y, der, xmin, xmax, ymin, ymax) + # V2.10.2 + #Memr[ptr1+j] = der[1] + #Memr[ptr2+j] = der[2] + # After V2.10.3 + Memr[ptr1+j] = x + Memr[ptr2+j] = y + + Memr[ptr3+j] = 1. / abs (der[4] * der[8] - der[5] * der[7]) + } + if (i == nv1) + break + + # Do the next line from right to left. + ptr1 = xgrid + i * nu1 - 1 + ptr2 = ygrid + i * nu1 - 1 + ptr3 = zgrid + i * nu1 - 1 + v = v1 + i * dv1 + do j = nu1, 1, -1 { + u = u1 + (j - 1) * du1 + call tr_invert (ct, Memi[usf], nusf, Memi[vsf], nvsf, u, v, + x, y, der, xmin, xmax, ymin, ymax) + # V2.10.2 + #Memr[ptr1+j] = der[1] + #Memr[ptr2+j] = der[2] + # V2.10.3 + Memr[ptr1+j] = x + Memr[ptr2+j] = y + Memr[ptr3+j] = 1. / abs (der[4] * der[8] - der[5] * der[7]) + } + } + + # Free the surfaces since we are now done with them. + if (ct != NULL) + call mfree (ct, TY_STRUCT) + for (i=1; i<=nusf; i=i+1) + if (Memi[usf+i-1] != NULL) + call xgsfree (Memi[usf+i-1]) + call mfree (usf, TY_POINTER) + for (i=1; i<=nvsf; i=i+1) + if (Memi[vsf+i-1] != NULL) + call xgsfree (Memi[vsf+i-1]) + call mfree (vsf, TY_POINTER) + + # Fit a linear interpolator to the subsampled grids of X(U,V), Y(U,V), + # and J(U,V) to avoid having to evaluate the inverse at each point in + # the output image. The inversion is slow because of the many + # evaluations of the surfaces coordinates. Also compute an return + # arrays mapping the output coordinates to the subsampled coordinates. + # This may include a transformation to logrithmic intervals. + + call msiinit (xmsi, II_BILINEAR) + call msifit (xmsi, Memr[xgrid], nu1, nv1, nu1) + call mfree (xgrid, TY_REAL) + + call msiinit (ymsi, II_BILINEAR) + call msifit (ymsi, Memr[ygrid], nu1, nv1, nu1) + call mfree (ygrid, TY_REAL) + + if (flux) { + call msiinit (jmsi, II_BILINEAR) + call msifit (jmsi, Memr[zgrid], nu1, nv1, nu1) + } + call mfree (zgrid, TY_REAL) + + # Compute the mapping between output coordinates and the subsampled + # interpolation surface. Also compute the intervals used to define + # the pixel areas for conserving flux. + + call malloc (uout, nu, TY_REAL) + call malloc (duout, nu, TY_REAL) + if (ulog) { + dval = log10 (double(u1)) + do i = 0, nu - 1 + Memr[uout+i] = 10.**(dval+i*du) + call amulkr (Memr[uout], du * LN_10, Memr[duout], nu) + } else { + do i = 0, nu - 1 + Memr[uout+i] = u1 + i * du + call amovkr (du, Memr[duout], nu) + } + u2 = Memr[uout+nu-1] + + call malloc (vout, nv, TY_REAL) + call malloc (dvout, nv, TY_REAL) + if (vlog) { + dval = log10 (double(v1)) + do i = 0, nv - 1 + Memr[vout+i] = 10.**(dval+i*dv) + call amulkr (Memr[vout], dv * LN_10, Memr[dvout], nv) + } else { + do i = 0, nv - 1 + Memr[vout+i] = v1 + i * dv + call amovkr (dv, Memr[dvout], nv) + } + v2 = Memr[vout+nv-1] + + # Convert to interpolation coordinates. + umin = 1.; umax = nu + do i = 0, nu - 1 + Memr[uout+i] = max (umin, min (umax, (Memr[uout+i]-u1)/du1+1)) + vmin = 1.; vmax = nv + do i = 0, nv - 1 + Memr[vout+i] = max (vmin, min (vmax, (Memr[vout+i]-v1)/dv1+1)) +end + + +define MAX_ITERATE 10 +define ERROR 0.05 +define FUDGE 0.5 + +# TR_INVERT -- Given user coordinate surfaces U(X,Y) and V(X,Y) +# (if none use one-to-one mapping and if more than one average) +# corresponding to a given U and V and also the various partial +# derivatives. This is done using a gradient following interative +# method based on evaluating the partial derivative at each point +# and solving the linear Taylor expansions simultaneously. The last +# point sampled is used as the starting point. Thus, if the +# input U and V progress smoothly then the number of iterations +# can be small. The output is returned in x and y and in the derivative array +# DER. A point outside of the surfaces is returned as the nearest +# point at the edge of the surfaces in the DER array. +# +# If a WCS is used then we let MWCS do the inversion and compute the +# derivatives numerically. + +procedure tr_invert (ct, usf, nusf, vsf, nvsf, u, v, x, y, der, + xmin, xmax, ymin, ymax) + +pointer ct #I CT pointer +pointer usf[ARB], vsf[ARB] #I User coordinate surfaces U(X,Y) and V(X,Y) +int nusf, nvsf #I Number of surfaces for each coordinate +real u, v #I Input U and V to determine X and Y +real x, y #O Output X and Y +real der[8] #U Last result as input, new result as output + # 1=X, 2=Y, 3=U, 4=DUDX, 5=DUDY, 6=V, + # 7=DVDX, 8=DVDY +real xmin, xmax, ymin, ymax #I Limits of coordinate surfaces. + +int i, j, nedge +real fudge, du, dv, dx, dy, a, b, tmp[4] + +begin + # If using a WCS we let MWCS do the inversion. + if (ct != NULL) { + call mw_c2tranr (CT_WL(ct), u, v, x, y) + call mw_c2tranr (CT_LW(ct), x-0.5, y, tmp[1], tmp[3]) + call mw_c2tranr (CT_LW(ct), x+0.5, y, tmp[2], tmp[4]) + der[4] = tmp[2] - tmp[1] + der[7] = tmp[4] - tmp[3] + call mw_c2tranr (CT_LW(ct), x, y-0.5, tmp[1], tmp[3]) + call mw_c2tranr (CT_LW(ct), x, y+0.5, tmp[2], tmp[4]) + der[5] = tmp[2] - tmp[1] + der[8] = tmp[4] - tmp[3] + return + } + + # Use the last result as the starting point for the next position. + # If this is near the desired value then the interation will converge + # quickly. Allow a iteration to go off the surface twice. + # Quit when DX and DY are within ERROR. + + nedge = 0 + do i = 1, MAX_ITERATE { + du = u - der[3] + dv = v - der[6] + a = der[8] * du - der[5] * dv + b = der[8] * der[4] - der[5] * der[7] + if (b == 0.) { + if (a < 0.) + dx = -2. + else + dx = 2. + } else + dx = a / b + a = dv - der[7] * dx + b = der[8] + if (b == 0.) { + if (a < 0.) + dy = -2. + else + dy = 2. + } else + dy = a / b + fudge = 1 - FUDGE / i + x = der[1] + fudge * dx + y = der[2] + fudge * dy + der[1] = max (xmin, min (xmax, x)) + der[2] = max (ymin, min (ymax, y)) +# if (x < xmin || x > xmax) +# nedge = nedge + 1 +# if (y < ymin || y > ymax) +# nedge = nedge + 1 +# if (nedge > 2) +# break + if ((abs (dx) < ERROR) && (abs (dy) < ERROR)) + break + + if (nusf == 0) + der[3] = der[1] + else if (nusf == 1) { + call xgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call xgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call xgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + } else { + call xgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call xgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call xgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + do j = 2, nusf { + call xgsder (usf[j], der[1], der[2], tmp[1], 1, 0, 0) + call xgsder (usf[j], der[1], der[2], tmp[2], 1, 1, 0) + call xgsder (usf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[3] = der[3] + tmp[1] + der[4] = der[4] + tmp[2] + der[5] = der[5] + tmp[3] + } + der[3] = der[3] / nusf + der[4] = der[4] / nusf + der[5] = der[5] / nusf + } + + if (nvsf == 0) + der[6] = der[2] + else if (nvsf == 1) { + call xgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call xgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call xgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + } else { + call xgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call xgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call xgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + do j = 2, nvsf { + call xgsder (vsf[j], der[1], der[2], tmp[1], 1, 0, 0) + call xgsder (vsf[j], der[1], der[2], tmp[2], 1, 1, 0) + call xgsder (vsf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[6] = der[6] + tmp[1] + der[7] = der[7] + tmp[2] + der[8] = der[8] + tmp[3] + } + der[6] = der[6] / nvsf + der[7] = der[7] / nvsf + der[8] = der[8] / nvsf + } + } +end + + +# TR_INIT -- Since the inversion iteration always begins from the last +# point we need to initialize before the first call to TR_INVERT. +# When using a WCS this simply returns. + +procedure tr_init (ct, usf, nusf, vsf, nvsf, x, y, der) + +pointer ct #I CT pointer +pointer usf[ARB], vsf[ARB] #I User coordinate surfaces +int nusf, nvsf #I Number of surfaces for each coordinate +real x, y #I Starting X and Y +real der[8] #O Inversion data + +int j +real tmp[3] + +begin + if (ct != NULL) + return + + der[1] = x + der[2] = y + if (nusf == 0) { + der[3] = der[1] + der[4] = 1. + der[5] = 0. + } else if (nusf == 1) { + call xgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call xgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call xgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + } else { + call xgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call xgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call xgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + do j = 2, nusf { + call xgsder (usf[j], der[1], der[2], tmp[1], 1, 0, 0) + call xgsder (usf[j], der[1], der[2], tmp[2], 1, 1, 0) + call xgsder (usf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[3] = der[3] + tmp[1] + der[4] = der[4] + tmp[2] + der[5] = der[5] + tmp[3] + } + der[3] = der[3] / nusf + der[4] = der[4] / nusf + der[5] = der[5] / nusf + } + + if (nvsf == 0) { + der[6] = der[2] + der[7] = 0. + der[8] = 1. + } else if (nvsf == 1) { + call xgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call xgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call xgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + } else { + call xgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call xgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call xgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + do j = 2, nvsf { + call xgsder (vsf[j], der[1], der[2], tmp[1], 1, 0, 0) + call xgsder (vsf[j], der[1], der[2], tmp[2], 1, 1, 0) + call xgsder (vsf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[6] = der[6] + tmp[1] + der[7] = der[7] + tmp[2] + der[8] = der[8] + tmp[3] + } + der[6] = der[6] / nvsf + der[7] = der[7] / nvsf + der[8] = der[8] / nvsf + } +end + + +# TR_EVAL -- Evalute coordinate function. +# +# This is an interface routine to allow using either an MWCS CT (coordinate +# transform) pointer or a GSURFIT SF (2D surface function) pointer. The +# surface method is used with a FITCOORDS database. The MWCS method is +# used to retransform an image with a WCS. + +real procedure tr_eval (ct, sf, axis, x, y) + +pointer ct #I CT pointer +pointer sf #I SF pointer +int axis #I World coordinate axis to return +real x, y #I Pixel coordinate to transform + +real w[2], xgseval() + +begin + if (sf != NULL) + return (xgseval (sf, x, y)) + + call mw_c2tranr (CT_LW(ct), x, y, w[1], w[2]) + return (w[axis]) +end + + +# TR_GETR -- Get real valued parameter. +# +# This is an interface routine to allow using either an MWCS CT (coordinate +# transform) pointer or a GSURFIT SF (2D surface function) pointer. The +# surface method is used with a FITCOORDS database. The MWCS method is +# used to retransform an image with a WCS. + +real procedure tr_getr (ct, sf, param) + +pointer ct #I CT pointer +pointer sf #I SF pointer +int param #I Parameter code + +real xgsgetr() + +begin + if (sf != NULL) + return (xgsgetr (sf, param)) + + switch (param) { + case GSXMIN, GSYMIN: + return (real (1)) + case GSXMAX: + return (real (CT_NX(ct))) + case GSYMAX: + return (real (CT_NY(ct))) + } +end diff --git a/noao/twodspec/longslit/x_longslit.x b/noao/twodspec/longslit/x_longslit.x new file mode 100644 index 00000000..7c33cf28 --- /dev/null +++ b/noao/twodspec/longslit/x_longslit.x @@ -0,0 +1,8 @@ +task extinction = t_extinction, + fceval = t_fceval, + fitcoords = t_fitcoords, + fluxcalib = t_fluxcalib, + illumination = t_illumination, + lscombine = t_lscombine, + response = t_response, + transform = t_transform |